6:29 PM  30-OCT-96
Fileman 21 through patch sequence 24
DDBR
DDBR ;SFISC/DCL-VA FILEMAN BROWSER ;MAY 17, 1995@10:35
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
 I '$$TEST^DDBRT W $C(7),!!,"This terminal does not support scroll region or reverse index",!! Q
 D LIST^DDBR3(.DDBX)
 I DDBX'>0 W:DDBX=0 $C(7),!!,"No Text",!! Q
 S DDBSA=DDBX(6)
 S DDBFLG=DDBX(4)
 S DDBPMSG=DDBX(5)
 D CONTNU
 D KTMP^DDBRU
 Q
WP(DDBFN,DDBRN,DDBFLD,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBSA
 S DDBSA=$$GET^DIQG($G(DDBFN),$G(DDBRN),$G(DDBFLD),"B")
 I $G(DIERR) D CLEAN Q
 S DDBSA=$P(DDBSA,"$CREF$",2)
 I DDBSA']"" D ERR("FILE, RECORD and/or FIELD") Q
 I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q
 S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1")
 D CONTNU
 D:$G(DDBFLG)'["P" KTMP^DDBRU
 Q
BROWSE(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBRLIST
CONTNU I $G(U)'="^" N U S U="^"
 S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1")
 N %,D,DX,IOP,XY,X,Y
 D:$G(DDBFLG)'["H" INIT I $G(DIERR) D CLEAN Q
 I $G(DDBSA)']"" D ERR("SOURCE ARRAY") Q
 I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q
 I $G(DDBFLG)'["N",DDBSA'="^TMP(""DDB"",$J)" D
 .I $NA(@DDBSA)=$NA(^TMP("DDB",$J)) S DDBSA="^TMP(""DDB"",$J)" Q
 .K ^TMP("DDB",$J)
 .D XY^%RCR($$OREF(DDBSA),"^TMP(""DDB"",$J,")
 .;M ^TMP("DDB",$J)=@DDBSA
 .S DDBSA="^TMP(""DDB"",$J)"
 .Q
 N DDBRE,DDBRPE,DDBPSA,DDBTO,DDBDM,DDBFNO,I,DDBFLGS
 N DDBHDR,DDBFTR,DDBSP,DDBSF,DDBST,DDBTL,DDBTPG,DDBZN
 I '$G(DDBRLIST) N DDBSRL,DDBSX,DDBSY,DDBRSA
 S DDBFTR=$E("Col>     |<PF1>H=Help <PF1>E=Exit| Line>                 Screen>"_$J("",IOM),1,IOM)
 I '$G(DDBRLIST) S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1
 S DDBRSA=0
 D TB^DDBRS(.IOTM,.IOBM,.DDBRSA)
 S DDBSX="0;4;40;65"
 S DDBSY=DDBRSA(0,"DDBSY")
 I IOBM>(IOSL-1) D ERR("BOTTOM MARGIN") Q
 I IOTM<2 D ERR("TOP MARGIN") Q
 I IOBM'>IOTM D ERR("TOP & BOTTOM MARGINS") Q
 S DDBSRL=DDBRSA(0,"DDBSRL")
 I DDBSRL'>4 D ERR("SCROLL REGION (TOO SMALL)") Q
 I DDBRSA(1,"DDBSRL")'>4 K DDBRSA(1),DDBRSA(2)
 S DDBHDR=$$CTXT(DDBPMSG,$J("",IOM+1),IOM)
 S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1)
 I DDBTL'>0 D  I DDBTL'>0 D BLD^DIALOG(1700,"*NO TEXT*"_DDBSA) D CLEAN Q
 .N I S I=0 F  S I=$O(@DDBSA@(I)) Q:I'>0  S DDBTL=I
 .Q
 S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBSF=1,DDBST=IOM
 S DDBDM=DDBSA="^TMP(""DDB"",$J)"
 I $G(DDBC)=+$G(DDBC) D ERR("TAB (Closed Array Root)") Q
 S:$G(DDBC)="" DDBC="^TMP(""DDBC"",$J)"
 I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)=""
 I $D(@DDBC@(1))'>9 N DDBC0,DDBC1 S @DDBC@(1)="",DDBC1=1,DDBC0=DDBC
 S DDBPSA=0,DDBFLG=$G(DDBFLG)
 S DDBFLGS=DDBFLG["S"
 G EN^DDBRGE
DOCLIST(DDBDSA,DDBFLG,IOTM,IOBM) S IOP="HOME" D ^%ZIS
 N DDBPMSG,DDBL,DDBC,DDBSA,DDBSRL,DDBSX,DDBSY,DDBRSA,DDBRLIST
 S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1
 S DDBSX="0;4;40;65"
 S DDBSY=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM)  ;hdr,txttop,txtbot,ftr
 I IOBM>(IOSL-1) D ERR("BOTTOM MARGIN") Q
 I IOTM<2 D ERR("TOP MARGIN") Q
 I IOBM'>IOTM D ERR("TOP & BOTTOM MARGINS") Q
 S DDBSRL=(IOBM-IOTM)+1  ;scroll region lines
 I '$D(@DDBDSA) D ERR("DOCUMENT ARRAY INVALID") Q
 S DDBFLG=$TR($G(DDBFLG),"P")_"N"
 S DDBPMSG=$O(@DDBDSA@("")) S:DDBPMSG]"" DDBSA=@DDBDSA@(DDBPMSG)
 I DDBPMSG']""!(DDBSA']"") D ERR("DOCUMENT ARRAY INVALID") Q
 D  I $G(DIERR) K ^TMP("DDBLST",$J) D CLEAN Q
 .N DOC,DOCSA
 .S DOC=""
 .K ^TMP("DDBLST",$J)
 .F  S DOC=$O(@DDBDSA@(DOC)) Q:DOC=""  D
 ..S DOCSA=@DDBDSA@(DOC)
 ..D LOADCL^DDBR4(DOCSA,"",DOC)
 ..Q
 .Q
 Q:$G(DDBENDR)
 S DDBRLIST=1
 G CONTNU
RTN G DR^DDBRU
ROOT G EN^DDBRU2
CTXT(X,T,W) Q:X="" $G(T)
 N HW
 S W=$G(W,79),HW=W\2
 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q $E(T,1,W)
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
INIT I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 D INIT^DDGLIB0()
 I $G(DIERR) Q
 I '$D(IOSTBM)!('$D(IOIL)) S X="IOSTBM;IORI" D ENDR^%ZISS
 D:$G(IOSTBM)="" TRMERR^DDGLIB0("Set top and bottom margins")
 D:$G(IORI)="" TRMERR^DDGLIB0("Reverse index")
 Q
ERR(DDBERR) N P S P(1)=DDBERR
 I $G(U)="^" N U S U="^"
 D BLD^DIALOG(202,.P),OUT^DDBRU:$D(DDGLDEL)
CLEAN D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
 Q

DDBR0
DDBR0 ;SFISC/DCL-VA FILEMAN BROWSER FUNCTIONS ;10:01 AM  24 Oct 1004;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
PU N I,J,K S I=DDBL-DDBSRL,J=I-(DDBSRL-1),K=DDBL
 S DX=$P(DDBSX,";"),DY=$P(DDBSY,";",2)
 I DDBZN D  D:K'=DDBL RLPI Q
 .F I=I:-1:J Q:'$D(@DDBSA@(I,0))  D
 ..X IOXY
 ..W IORI,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I,0),DDBSF,DDBST)
 ..S DDBL=DDBL-1
 F I=I:-1:J Q:'I!('$D(@DDBSA@(I)))  D
 .X IOXY
 .W IORI,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I),DDBSF,DDBST)
 .S DDBL=DDBL-1
 D:K'=DDBL RLPI
 Q
PD N I,J,K S I=DDBL+1,J=DDBL+DDBSRL,K=DDBL
 S DX=0,DY=$P(DDBSY,";",3)
 X IOXY
 I DDBZN D  D:K'=DDBL RLPI Q
 .F I=I:1:J Q:'$D(@DDBSA@(I,0))  W !,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I,0),DDBSF,DDBST) S DDBL=DDBL+1
 .Q
 F I=I:1:J Q:'$D(@DDBSA@(I))  W !,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I),DDBSF,DDBST) S DDBL=DDBL+1
 D:K'=DDBL RLPI
 Q
LU N I S I=DDBL-DDBSRL
 S DX=0,DY=$P(DDBSY,";",2)
 X IOXY
 I DDBZN Q:'$D(@DDBSA@(I,0))  S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I,0),DDBSF,DDBST) D RLPIR Q
 I I,$D(@DDBSA@(I)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(I),DDBSF,DDBST) D RLPIR Q
 Q
LD S DX=0,DY=$P(DDBSY,";",3)
 X IOXY
 I DDBZN,$D(@DDBSA@(DDBL+1,0)) D  Q
 .S DDBL=DDBL+1
 .W !,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(DDBL,0),DDBSF,DDBST)
 .D RLPIR
 .Q
 I 'DDBZN,$D(@DDBSA@(DDBL+1)) D  Q
 .S DDBL=DDBL+1
 .W !,$P(DDGLCLR,DDGLDEL),$E(@DDBSA@(DDBL),DDBSF,DDBST)
 .D RLPIR
 .Q
 Q
COL(N) N X
 S X=$O(@DDBC@(DDBSF),N) Q:X'>0
 S DDBSF=X
COLENT S DDBST=DDBSF+(IOM-1),DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
 D SDLR(DDBL+1),COLR
 Q
COLJ N X
COLA S X(2)="Col> " W $$WS^DDBR1(.X) D  G:X=""!(X=U) OUT
 .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X)
 .K DIR0
 .Q
 I $E(X)="?" G COLERR
 I X<1!(X>255) W $C(7) G COLERR
 S DDBSF=X G COLENT
 Q
COLERR S X(1)="    * [ Enter a number between 1 and 255 ] *"
 G COLA
OUT D PSR^DDBR0()
 Q
RLE S DDBSF=1 G COLENT
RRE S DDBSF=$O(@DDBC@(""),-1) G COLENT
HELPS N DDBHELPS
 S DDBHELPS=58+DDBSRL
HELP I DDBSA="^DI(.84,9201,2)" S DDBL=0 D SDLR^DDBR0(1),RLPIR Q
 N DDBHA S DDBHA="^DI(.84,9201,2)"
 D BROWSE^DDBR(DDBHA,"PNH","VA FileMan Help Document",$G(DDBHELPS),"",IOTM-1,IOBM+1)
 W @IOSTBM
 D PSR^DDBR0(1)
 Q
ONLINE Q
RR D COL(1)
 Q
RL D COL(-1)
 Q
TOP S DDBL=0 D SDLR(1),RLPIR
 Q
BOT I DDBTL>DDBSRL S DDBL=DDBTL-DDBSRL D SDLR(DDBL+1),RLPIR
 Q
EXIT S DDBRE="^"
 Q
TO S DDBTO=DDBTO+1,DDBE=-1 S:DDBTO'<($G(DTIME,300)\5) DDBE="^"
 Q
RCLSI D RLPIR,COLR
 Q
PSR(PSR) S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
 D:$G(PSR) HFR D SDLR(DDBL+1),RLPIR,COLR
 Q
SDL ;
SDLR(L) N I,J,SFR,STO
 S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L
 S DY=SFR X IOXY
 I DDBZN F I=SFR:1:STO D
 .W:I'=SFR !
 .W $P(DDGLCLR,DDGLDEL)
 .I J=L,$D(@DDBSA@(L)) W $E(@DDBSA@(L,0),DDBSF,DDBST) S DDBL=DDBL+1,L=L+1
 .S J=J+1
 .Q
 I 'DDBZN F I=SFR:1:STO D
 .W:I'=SFR !
 .W $P(DDGLCLR,DDGLDEL)
 .I J=L,$D(@DDBSA@(L)) W $E(@DDBSA@(L),DDBSF,DDBST) S DDBL=DDBL+1,L=L+1
 .S J=J+1
 .Q
 Q
HFR N FTR S FTR=1
HDR S DX=0
 S DY=$P(DDBSY,";")
 X IOXY
 W $P(DDGLVID,DDGLDEL,6)
 W DDBHDR
 W $P(DDGLVID,DDGLDEL,10)
 G:$G(FTR) FTR
 Q
FTR I DDBFLGS Q
 W $P(DDGLVID,DDGLDEL,6)
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
 S DY=$P(DDBSY,";",4)
 X IOXY
 W DDBFTR
 S DX=$P(DDBSX,";",3)
 X IOXY
 W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)," of ",DDBTL
 S DX=$P(DDBSX,";",4)
 X IOXY
 W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)," of ",DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
 S DX=$P(DDBSX,";",2)
 X IOXY
 W $J(DDBSF,4)
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
 W $P(DDGLVID,DDGLDEL,10)
 Q
 W $P(DDGLVID,DDGLDEL,10)
 Q
RLPI ;
RLPIR I DDBFLGS Q
 S DX=$P(DDBSX,";",3),DY=$P(DDBSY,";",4)
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
 W $P(DDGLVID,DDGLDEL,6)
 X IOXY
 W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)
 S DX=$P(DDBSX,";",4)
 X IOXY
 W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
 W $P(DDGLVID,DDGLDEL,10)
 Q
COLR I DDBFLGS Q
 S DX=$P(DDBSX,";",2),DY=$P(DDBSY,";",4)
 X IOXY
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
 W $P(DDGLVID,DDGLDEL,6)
 W $J(DDBSF,4)
 I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
 W $P(DDGLVID,DDGLDEL,10)
 Q

DDBR1
DDBR1 ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS;04:22 PM  20 Oct 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
GOTO N X
GTR S X(1)=$G(X(1)),X(2)="GoTo >" W $$WS(.X) D  G:X=""!(X=U) OUT
 .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X)
 .K DIR0
 .Q
 I $E(X)="?" S X(1)="* Screen (default), line or column number preceeded by 'S', 'L' or 'C' *" G GTR
 I X S X=X*DDBSRL G LINE
 S $E(X)=$TR($E(X),"bclst","BCLST")
 I X["S",$TR($P(X,"S",2)," ") S X=$TR($P(X,"S",2)," ")*DDBSRL G LINE
 I X["L",$TR($P(X,"L",2)," ") S X=$TR($P(X,"L",2)," ") G LINE
 I X["C",$TR($P(X,"C",2)," ") S X=$TR($P(X,"C",2)," ") I X>0&(X<256) S DDBSF=X G COLENT^DDBR0
 I $E(X)="T" G TOP^DDBR0
 I $E(X)="B" G BOT^DDBR0
 G OUT
LINE S DDBL=$S(X'>DDBSRL:0,X>DDBTL:DDBTL,1:X) D PSR^DDBR0()
 Q
NOOF N N
 S N=1 I $D(DDBFNO) N D,X G FNO
 S X(1)="    * [ NO PREVIOUS FIND STRING AVAILABLE ] *"
 N Q S N=0 G BPR
FIND N D,Q,X
 N N
 S N=0
BPR S X(1)=$G(X(1)),X(2)="Find What:  " W $$WS(.X) D  G:X="" OUT
 .N Y
 .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,$P($G(DDBFNO),U,3,255),100,1,"","KPW",.X,.Y)
 .K DIR0
 .S:$P($G(Y),U)="U" X=X_"/U"
 .Q
 S Q=$TR($E(X,$L(X)-1,$L(X)),"u","U")
 S D=$S(Q="/U":-1,1:1)
 S:D=-1 X=$E(X,1,$L(X)-2)
 Q:X=""
 I $E(X)="?" S X(1)="    * [ Please enter any characters <cr>, '^' <cr> (exit) ] *" G BPR
FNO N I,MATCHI,MATCHX
 I N S D=$P(DDBFNO,"^",2),X=$P(DDBFNO,"^",3,255)
 S X(1)="",X(2)="    * [ ...Searching "_$S(D=1:"'DOWN'",1:"'UP'")_" for "_X_"... ] *" W $$WS(.X)
 D  S:I<0 I=0
 .I N&(D=1) S I=DDBL Q
 .I N S I=DDBL-(DDBSRL-1) Q
 .I D=1 S I=DDBL-DDBSRL Q
 .S I=DDBL+1
 .Q
 D
 .N XUC
 .S XUC=$$U(X)
 .I DDBDM D  Q
 ..I DDBZN D  Q
 ...F  S I=$O(^TMP("DDB",$J,I),D) Q:I'>0  I $$U($G(^(I,0)))[XUC S MATCHI=I,MATCHX=^(0) Q
 ...Q
 ..F  S I=$O(^TMP("DDB",$J,I),D) Q:I'>0  I $$U(^(I))[XUC S MATCHI=I,MATCHX=^(I) Q
 ..Q
 .I DDBZN D  Q
 ..F  S I=$O(@DDBSA@(I),D) Q:I'>0  I $$U($G(@DDBSA@(I,0)))[XUC S MATCHI=I,MATCHX=@DDBSA@(I,0) Q
 ..Q
 .F  S I=$O(@DDBSA@(I),D) Q:I'>0  I $$U(@DDBSA@(I))[XUC S MATCHI=I,MATCHX=@DDBSA@(I) Q
 .Q
 I $G(MATCHI) D  S DDBFNO=DDBL_"^"_D_"^"_X Q
 .S DDBSF=1,DDBST=IOM F  Q:$F(MATCHX,X)'>DDBST  D
 ..S DDBSF=$O(@DDBC@(DDBSF)) S:DDBSF="" DDBSF=$O(@DDBC@(""))
 ..S DDBST=DDBSF+(IOM-1)
 ..Q
 .I I+(DDBSRL)>DDBTL S I=DDBTL-(DDBSRL-1)
 .I DDBTL'>DDBSRL S I=1
 .S DDBL=I-1 D SDLRH(I,X),RCLSI^DDBR0
 .Q
 S X(1)="",X(2)="    * [ NO"_$S(N:" OTHER ",1:" ")_"MATCH FOUND ] *" W $C(7),$$WS(.X) H 3
 D PSRH
 Q
OUT D PSR^DDBR0()
 Q
PSRH S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
 D SDLRH(DDBL+1,X)
 Q
SDL ;
SDLRH(L,HLS) N I,J,SFR,STO
 S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L
 S DY=SFR X IOXY
 I DDBZN F I=SFR:1:STO D
 .W:I'=SFR !
 .W $P(DDGLCLR,DDGLDEL)
 .I J=L,$D(@DDBSA@(L)) W $$HL($E(@DDBSA@(L,0),DDBSF,DDBST),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,10)) S DDBL=DDBL+1,L=L+1
 .S J=J+1
 .Q
 I 'DDBZN F I=SFR:1:STO D
 .W:I'=SFR !
 .W $P(DDGLCLR,DDGLDEL)
 .I J=L,$D(@DDBSA@(L)) W $$HL($E(@DDBSA@(L),DDBSF,DDBST),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,10)) S DDBL=DDBL+1,L=L+1
 .S J=J+1
 .Q
 Q
HL(X,S,ON,RS,F) S X=$G(X),S=$G(S),F=$G(F)=1
 G:F CS
 N C,I,P,T,XU,SU,SL,TL,XL
 S XU=$$U(X),SU=$$U(S),SL=$L(S),C=$L(XU,SU)-1,T="",XL=0
 Q:'C X
 F I=1:1:C S P=$F(XU,SU,XL),T=T_$E(X,XL,P-SL-1)_ON_$E(X,P-SL,P-1)_RS,XL=P
 S T=T_$E(X,XL,255)
 Q T
U(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CS Q:$L(X,S)'>1 X
 N C,I,P,T
 S T="",C=$L(X,S)
 F I=1:1:C S P=$P(X,S,I),T=T_P_$S(I'=C:ON_S_RS,1:"")
 Q T
HELP(DDBHELP) N I,J
 I DDBSA="^DI(.84,9201,2)" S DDBL=0 D SDLR^DDBR0(1),RCLSI^DDBR0 Q
 N DDBHA S DDBHA="^DI(.84,9201,2)"
 D BROWSE^DDBR(DDBHA,"PNH","VA FileMan Help Document","","",IOTM,IOBM,DDBHELP),PSR^DDBR0(1)
 Q
LC(L,C) Q:$G(L)'>0 ""
 S C=$G(C,"-")
 Q $TR($J("",L)," ",C)
WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY
 W $P(DDGLGRA,DDGLDEL)
 W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))
 W $P(DDGLGRA,DDGLDEL,2)
 W !,$P(DDGLCLR,DDGLDEL),$G(X(1))
 W !,$P(DDGLCLR,DDGLDEL),$G(X(2))
 W !,$P(DDGLCLR,DDGLDEL),$G(X(3))
 S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY
 Q ""

DDBR2
DDBR2 ;SFISC/DCL-VA FILEMAN BROWSER ;09:34 AM  24 Oct 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
SWITCH(DDBLST,DDBRET) ;Switch to another document in list or FileMan Database
 I DDBSA="^DI(.84,9201,2)" D EXIT^DDBR0 Q  ;!(DDBSA="^XTMP(""DDBDOC"")") Q
 N DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN
 S DILN=DDBRSA(DDBRSA,"DDBSRL")-2
 S:$G(DDBLST)="" DDBLST="^TMP(""DDBLST"",$J)" S DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
 I DDBFLG["R",'$D(@DDBLST) D SFR() G PS
 I $G(DDBRET)["R" D  G:$G(Y) PS Q
 .Q:DDBPSA'>0
 .Q:'$D(@DDBLST@("APSA",DDBPSA))  S X=^(DDBPSA) S:$D(@DDBLST@("A",X)) Y=^(X)
 .I $G(Y) S DDBPSA=DDBPSA-1 N DDBPSA D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y)
 .Q
BRMC D BRM
 I $D(@DDBLST) D
 .I $O(@DDBLST@(" "),-1)=1,$G(@DDBLST@(1,"DDBSA"))=DDBSA Q
 .;W "Current list: ",!
 .S DDBZ=$G(@DDBLST@("A",DDBSA),0)
 .;S X=0 F  S X=$O(@DDBLST@(X)) Q:X'>0  W:X'=DDBZ !,$J(X,3),"  ",$E(@DDBLST@(X,0),1,75)
 .W !
 .K DIR0
 .S DIR(0)="Y",DIR("A")="Do you wish to select from current list? ",DIR("B")="YES" D ^DIR,SFR("to Current List"):Y=0&(DDBFLG["R") Q:$D(DIRUT)!(Y'>0)
 .S DIC=$$OREF^DIQGU(DDBLST),DIC(0)="EMQ",DIC("S")="I +Y'=DDBZ",DIC("W")="W:$E(^(0))=U ^(0)",X="??" D ^DIC  ;K DIC("S") Q:Y'>0
 .S DIC(0)="AEMQ"
 .D ^DIC K DIC("S") Q:Y'>0
 .D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y)
 .S DIROUT=1
 N DDBLNA
 S:DDBFLG["R" DIROUT=1
 I '$D(DIROUT) D LIST^DDBR3(.DDBLNA)
 I $G(DDBLNA,-1)=-1 G PS
 I $G(DDBLNA(6))=DDBSA G PS  ;if current document selected again
 I $G(DDBLNA(6))]"",$D(@DDBLST@("APSA",DDBSA)) G PS  ;if already in list
 I DDBLNA'>0 W $C(7),!!,"** NO TEXT** ",DDBLNA(5) H 3
 D:DDBLNA>0 SAVEDDB(DDBLST,DDBLN),WP(.DDBLNA)
PS D PSR^DDBR0(1)
 Q
 ;
WP(DDBX) ;
 S DDBSA=DDBX(6)
 S DDBPMSG=DDBX(5)
 S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM)
 S DDBTL=$P(@DDBSA@(0),"^",3)
 S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
 S DDBZN=1
 S DDBDM=0
 S DDBSF=1
 S DDBST=IOM
 S DDBC="^TMP(""DDBC"",""DDBC"",$J)"
 I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)=""
 S DDBL=0
 Q
 ;
SAVEDDB(DDBLIST,IEN,NSAPSA) ;Save local varialbes into ^TMP("DDBLIST",$J,IEN)
 ;DDBS  array to save list
 ;IEN   internal entry
 ;NSAPSA Not Set "APSA" x-ref if undefined, pass 1 to not set NSAPSA (optional - default is to set "APSA")
 S NSAPSA=+$G(NSAPSA)
 N I,X
 F I="HDR","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@DDBLIST@(IEN,X)=@X
 ;I $D(DDBFNO) S @DDBLIST@(IEN,DDBFNO)=DDBFNO  ;decided to keep it the same throughout the browse session (Next Find String)
 S @DDBLIST@(IEN,0)=DDBPMSG
 S:'$D(@DDBLIST@(0)) ^(0)="CURRENT LIST^1"
 S:'$D(@DDBLIST@("A",DDBSA)) @DDBLIST@("A",DDBSA)=IEN
 S:'$D(@DDBLIST@("B",DDBPMSG,IEN)) @DDBLIST@("B",DDBPMSG,IEN)=""
 I $G(DDBRET)["R",DDBRPE=DDBRE Q
 Q:NSAPSA
 S X=$O(@DDBLST@("APSA"," "),-1)+1
 I $G(@DDBLIST@("APSA",X-1))=DDBSA S DDBPSA=X-1 Q
 S @DDBLIST@("APSA",X)=DDBSA,DDBPSA=X
 Q
 ;
USAVEDDB(DDBLIST,IEN) ;Unsave varialbes in ^TMP("DDBLIST",$J,IEN) to locals
 ;DDBS  array to save list
 ;IEN   internal entry
 N I,X
 F I="HDR","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@X=@DDBLIST@(IEN,X)
 S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
 ;I $D(@DDBLIST@(IEN,"DDBFNO")) S DDBFNO=@DDBLIST@(IEN,"DDBFNO")
 Q
 ;
 ;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
 Q:X="" $G(T)
 N HW
 S W=$G(W,79),HW=W\2
 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
 ;
BRM ;BROWSE MANAGER SCREEN
 N DX,DY,X
 S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("BROWSE SWITCH MANAGER",$J("",IOM+1),IOM)
 X IOXY
 W $P(DDGLVID,DDGLDEL,6)  ;rvon
 W $P(DDGLVID,DDGLDEL,4)  ;uon
 W X
 W $P(DDGLVID,DDGLDEL,10)  ;rvoff
 F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
 W $P(DDGLVID,DDGLDEL,6)  ;rvon
 W $P(DDGLVID,DDGLDEL,4)  ;uon
 W X
 W $P(DDGLVID,DDGLDEL,10)  ;rvoff
 W @IOSTBM
 S DY=$P(DDBSY,";",2)
 X IOXY
 Q
 ;
SFR(Y) N X
 S X(1)="",X(2)=$$CTXT^DDBR("<< SWITCH Function Restricted "_$G(Y)_" >>","",IOM)
 W $$WS^DDBR1(.X),$C(7)
 R X:3
 Q

DDBR3
DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;02:27 PM  24 Oct 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LIST(DDBLIST) ;DDBLIST=Target array for file number,ien,field,...
 S DDBLIST=-1  ;no selection
EN ;
 N %,%H,%ZISOS,A,D,D0,D1,DA,DDBB,DDBDDF,DDBDIC,DDBFRCD,DDBIEN,DDBRCR,DDBX,DIC,DICS,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y
 ;S DIC=1,DIC(0)="AEMQ" D ^DIC Q:+Y'>0  ;Select file
 D ^DICRW Q:Y'>0
 S DIC="^DD("_+Y_",",DIC(0)="AEMQ"
M S DIC("W")="I $P(^(0),U,2) W $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":""  (word-processing)"",1:""  (multiple)"")"
 S DIC("S")="I $P(^(0),U,2)"
 D ^DIC I +Y'>0,$D(@(DIC_"0,""UP"")")) S DIC="^DD("_+^("UP")_"," G M ;Select field/back out of multiples
 Q:+Y'>0
 I $P(@(DIC_+Y_",0)"),U,2) S DIC="^DD("_+$P(^(0),U,2)_",",Y=.01 G D:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",M
D ;
 K DIC("S")
 S DDBDIC=$$UP^DIQGU(+$P(DIC,"^DD(",2),.DDBDIC),(DDBX,DDBIEN)=""
 S DDBFRCD=$$GET^DIQGDD(DDBDIC,"","NAME")_":[",DDBB=0
 F  S DDBX=$O(DDBDIC(DDBX)) Q:DDBX'<0  D  Q:$G(Y)'>0
 .K DA D IEN(","_DDBIEN,.DA)
 .S DIC=$$ROOT^DIQGU(+DDBDIC(DDBX),","_DDBIEN),DIC(0)="AEMQ" Q:DIC']""
 .S DDBRCR=$$CREF^DILF(DIC)
 .I $P($G(@DDBRCR@(0)),U,4)'>0 D  K DDBIEN Q
 ..W $C(7),!!,"No Records at "_$S(DDBDIC=+DDBDIC(DDBX):"FILE",1:$P(^DD(+DDBDIC(DDBX),.01,0),U))_" Level.",!
 ..Q
 .D ^DIC I Y'>0 K DDBIEN Q
 .S DDBIEN=+Y_","_DDBIEN
 .S DDBFRCD=DDBFRCD_$S(DDBB:"\",1:"")_$$GET^DIQG(+DDBDIC(DDBX),DDBIEN,.01),DDBB=1
 .K DA D IEN(DDBIEN,.DA)
 .Q
DISP ;
 S DDBDDF=$O(^DD(+DDBDIC(-1),"SB",+DDBDIC(0),"")) Q:'DDBDDF
 S DDBFRCD=DDBFRCD_"] (wp): "_$P(^DD(DDBDIC(0),.01,0),"^")
 I $D(DDBIEN) D  Q
 .N DDBX S DDBX=$P($$GET^DIQG(+DDBDIC(-1),DDBIEN,DDBDDF,"B"),"$CREF$",2)
 .S DDBLIST=$D(@DDBX)
 .S DDBLIST(1)=+DDBDIC(-1)
 .S DDBLIST(2)=DDBIEN
 .S DDBLIST(3)=DDBDDF
 .S DDBLIST(4)="N"
 .S DDBLIST(5)=DDBFRCD
 .S DDBLIST(6)=DDBX
 .Q
 Q
IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)=""  S DA(I-1)=$P(IEN,",",I)
 Q

DDBR4
DDBR4 ;SFISC/DCL-LOAD CURRENT LIST :13 AM  27 Dec 1993;10:28 AM  28 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOADCL(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,DDBLST) ;
 ;DDBSA=source array by value
 ;DDGFLG=no flags currently available
 ;DDBPMSG=text to be displayed (centered) on top line
 ;DDBL=display line default 1st screen/line (22 in most cases)
 ;DDBC=location of column tab array used with right/left arrow keys
 ;DDBLST=location of current list (BROWSER expects ^TMP("DDBLST",$J))
 I $G(DDBSA)']"" N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q
 I '$D(@DDBSA) N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q
 N DDBRE,DDBLN,DDBRPE,DDBPSA,DDBTO,I,X,Y
 N DDBFNO,DDBDM,DDBSF,DDBTL,DDBTPG,DDBZN,DDBFTR,DDBHDR,DDBST
 S DDBHDR=$$CTXT($G(DDBPMSG,"VA FileMan Browser"),$J("",IOM+1),IOM)
 S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1)
 I DDBTL'>0 D  I DDBTL'>0 D BLD^DIALOG(1700,"*NO TEXT* "_DDBSA) Q
 .N I S I=0 F  S I=$O(@DDBSA@(I)) Q:I'>0  S DDBTL=I
 .Q
 S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBDM=DDBSA="^TMP(""DDB"",$J)",DDBSF=1
 S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)")
 S DDBPSA=0,DDBFLG=$G(DDBFLG)
 S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL
 S (DDBRE,DDBRPE)="",DDBTO=0,DDBST=IOM
 S DDBLST=$G(DDBLST,"^TMP(""DDBLST"",$J)"),DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
 D SAVEDDB^DDBR2(DDBLST,DDBLN,1)
 Q
 ;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
 Q:X="" $G(T)
 N HW
 S W=$G(W,79),HW=W\2
 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %

DDBRGE
DDBRGE ;SFISC/DCL-BROWSE GET/EXECUTE EVENT ;03:27 PM  29 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN N DDBGF
 D GETKEY
 S DDBRPE=0
 W @IOSTBM
 S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1)
 S DX=0,DY=$P(DDBSY,";",3) X IOXY
 X DDGLZOSF("EOFF")
 F  S DDBRE=$$READ D  Q:DDBRE="^"
 .I $T(@DDBRE)="" W $C(7) Q
 .X DDGLZOSF("EON")
 .D @DDBRE
 .I DDBRSA S DDBRSA(DDBRSA,"DDBL")=DDBL
 .S DX=0,DY=$P(DDBSY,";",3) X IOXY
 .S DDBRPE=DDBRE
 .X DDGLZOSF("EOFF")
 X DDGLZOSF("EON")
 I $G(DDBFLG)["H" Q
CLS S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
 I DDBRSA S X=DDBL D
 .N DDBL S DDBL=X
 .D SR^DDBRS(DDBRSA,$S(DDBRSA=2:1,1:2),.DDBRSA)
 .W @IOSTBM
 .S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
 .Q
 I $G(DDBC1),$G(DDBC0)]"" K @DDBC0@(1)
 K ^TMP("DDBC","DDBC",$J)
 S IOTM=1,IOBM=IOSL W @IOSTBM,$P(DDGLVID,DDGLDEL,9)
 D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
 S DX=0,DY=IOSL-1 X IOXY
 I DDBSRL+2=IOSL W @IOF
 D:$G(DDBFLG)'["P" KTMP
END Q
KTMP D KTMP^DDBRU
 Q
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDBGF("DDBIN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDBGF("DDBIN")'[(U_S_U) Y=-1
 I DDBGF("DDBIN")[(U_S_U),S'=$C(27) S Y=$P(DDBGF("DDBOUT"),U,$L($P(DDBGF("DDBIN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q
GETKEY N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T
 N FIND,SELECT,PREVSC,NEXTSC,HELP,KP7,KP8
 S AU=$P(DDGLKEY,U,2)
 S AD=$P(DDGLKEY,U,3)
 S AR=$P(DDGLKEY,U,4)
 S AL=$P(DDGLKEY,U,5)
 S F1=$P(DDGLKEY,U,6)
 S F2=$P(DDGLKEY,U,7)
 S F3=$P(DDGLKEY,U,8)
 S F4=$P(DDGLKEY,U,9)
 S FIND=$P(DDGLKEY,U,10)
 S SELECT=$P(DDGLKEY,U,11)
 S PREVSC=$P(DDGLKEY,U,14)
 S NEXTSC=$P(DDGLKEY,U,15)
 S HELP=$P(DDGLKEY,U,16)
 S KP7=$P(DDGLKEY,U,25)
 S KP8=$P(DDGLKEY,U,26)
 F N="DDB" D
 . S DDBGF(N_"IN")="",DDBGF(N_"OUT")=""
 . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T=""  D
 .. S @("K="_$P(T,";",2))
 .. I DDBGF(N_"IN")'[(U_K) D
 ... S DDBGF(N_"IN")=DDBGF(N_"IN")_U_K
 ... S DDBGF(N_"OUT")=DDBGF(N_"OUT")_$P(T,";")_U
 . S DDBGF(N_"IN")=DDBGF(N_"IN")_U
 . S DDBGF(N_"OUT")=$E(DDBGF(N_"OUT"),1,$L(DDBGF(N_"OUT"))-1)
 Q
TO S DDBRE="^" Q
HELP D HELP^DDBR0 Q
HELPS D HELPS^DDBR0 Q
RETURN D SWITCH^DDBR2("","R") Q
SWITCH D SWITCH^DDBR2() Q
RPS I 'DDBRSA D PSR^DDBR0(1) Q
 N DDBRNI F DDBRNI=1,2 D
 .I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q
 .I DDBRSA=1 S DDBL=DDBRSA(DDBRSA,"DDBL") D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q
 .Q
 Q
NEXT D NOOF^DDBR1 Q
FIND D FIND^DDBR1 Q
GOTO D GOTO^DDBR1 Q
BOT D BOT^DDBR0 Q
TOP D TOP^DDBR0 Q
PD D PD^DDBR0 Q
PU D PU^DDBR0 Q
QUIT ;
EXIT D EXIT^DDBR0 Q
COLR D RR^DDBR0 Q
COLL D RL^DDBR0 Q
COLRE D RRE^DDBR0 Q
COLLE D RLE^DDBR0 Q
COLJ D COLJ^DDBR0 Q
LND D LD^DDBR0 Q
LNU D LU^DDBR0 Q
PF1Z I $G(^TMP("DDBPF1Z",$J))]""  X ^($J) G RPS
 G BQT
PF2Z I $G(^TMP("DDBPF2Z",$J))]""  X ^($J) G RPS
 G BQT
PF3Z I $G(^TMP("DDBPF3Z",$J))]""  X ^($J) G RPS
 G BQT
PF4Z I $G(^TMP("DDBPF4Z",$J))]""  X ^($J) G RPS
 G BQT
SCRN1 I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM G RPS
 G BQT
SCRN2 I DDBRSA=1 D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM G RPS
 G BQT
SPLIT I 'DDBRSA,$D(DDBRSA(1)) D SPLIT^DDBRS Q
 G BQT
FULL I DDBRSA D FULL^DDBRS(.DDBRSA) Q
 G BQT
RESIZU I DDBRSA,(DDBRSA(1,"IOBM")-1)>(DDBRSA(0,"IOTM")+2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")-1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")-1 D 2,1,ENTB^DDBRS(.DDBRSA,-1) G RPS
 G BQT
RESIZD I DDBRSA,(DDBRSA(2,"IOTM")+1)<(DDBRSA(0,"IOBM")-2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")+1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")+1 D 1,2,ENTB^DDBRS(.DDBRSA,+1) G RPS
 G BQT
BQT W $C(7)
 Q
1 S DX=0,DY=$P(DDBRSA(1,"DDBSY"),";",4) X IOXY W $P(DDGLCLR,DDGLDEL) Q
2 S DX=0,DY=$P(DDBRSA(2,"DDBSY"),";") X IOXY W $P(DDGLCLR,DDGLDEL) Q
DDBMAP ;
 ;;LNU;AU;
 ;;LND;AD;
 ;;COLR;AR;
 ;;COLL;AL;
 ;;EXIT;F1_"E";
 ;;QUIT;F1_"Q";
 ;;PU;F1_AU;
 ;;PU;PREVSC;
 ;;PD;F1_AD;
 ;;PD;NEXTSC;
 ;;COLRE;F1_AR;
 ;;COLLE;F1_AL;
 ;;COLJ;F1_"C";
 ;;TOP;F1_"T";
 ;;BOT;F1_"B";
 ;;GOTO;F1_"G";
 ;;FIND;F1_"F";
 ;;FIND;FIND;
 ;;NEXT;"N";
 ;;NEXT;F1_"N";
 ;;RPS;F1_"P";
 ;;SWITCH;F1_"S";
 ;;SWITCH;SELECT;
 ;;RETURN;"R";
 ;;HELP;F1_"H";
 ;;HELP;"HELP";
 ;;HELPS;F1_F1_"H";
 ;;PF1Z;F1_"Z";     ^TMP(""DDBPF1Z",$J)=executable code (user defined)
 ;;PF2Z;F2_"Z";     ^TMP(""DDBPF2Z",$J)=executable code (user defined)
 ;;PF3Z;F3_"Z";     ^TMP(""DDBPF3Z",$J)=executable code (user defined)
 ;;PF4Z;F4_"Z";     ^TMP(""DDBPF4Z",$J)=executable code (user defined)
 ;;EXIT;"EXIT";
 ;;SCRN1;F2_AU;
 ;;SCRN2;F2_AD;
 ;;SPLIT;F2_"S";
 ;;FULL;F2_"F";
 ;;RESIZU;F2_F2_AU;
 ;;RESIZD;F2_F2_AD;

DDBRS
DDBRS ;SFISC/DCL-SET UP SPLIT SCREEN ;09:27 AM  13 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
TB(IOTM,IOBM,TA) ;Set Top and Bottom Margins in Target Array
 ;pass IOTM, IOBM and TA all by reference **
 N I,X
 I (((IOBM-IOTM)+1)#2) S IOBM=IOBM-1
 S TA(0,"IOTM")=IOTM
 S TA(0,"IOBM")=IOBM
ETA S X=((IOBM+1)-(IOTM-1)\2)-2
 S TA(1,"IOTM")=IOTM
 S TA(1,"IOBM")=IOTM+X
 S TA(2,"IOBM")=IOBM
 S TA(2,"IOTM")=IOBM-X
ETB D
 .N IOTM,IOBM
 .F I=+$G(I):1:2 S IOTM=TA(I,"IOTM"),IOBM=TA(I,"IOBM") D
 ..S TA(I,"DDBSY")=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM)
 ..S TA(I,"DDBSRL")=(IOBM-IOTM)+1
 ..Q
 .Q
 Q
 ;
ENTB(TA,DDBLD) ;called to reset DDBSY and DDBSRL for resizing split screen
 ;TA PASSED BY REFERENCE
 N I
 S I=1
 D ETB
 F I=1,2 S TA(I,"DDBTPG")=TA(I,"DDBTL")\TA(I,"DDBSRL")+(TA(I,"DDBTL")#TA(I,"DDBSRL")'<1)
 F I="DDBTPG","DDBSY","DDBSRL" S @I=TA(TA,I)
 I DDBLD<0 S TA(1,"DDBL")=TA(1,"DDBL")-$S(TA(1,"DDBL")>0:1,1:0) Q
 S TA(1,"DDBL")=TA(1,"DDBL")+$S(TA(1,"DDBL")<TA(1,"DDBTL"):1,1:0) Q
 Q
 ;
INIT(SUB,TA) ;Finish saving variables for TA pass TA by reference **
 N I G:$G(SUB)]"" SUB
 F SUB=1,2 D SUB
 Q
SUB F I="DDBSRL","DDBHDR","DDBTL","DDBSA","DDBSF","DDBST","DDBZN","DDBDM","DDBC","DDBPSA","DDBRPE","DDBPMSG","DDBTPG" S TA(SUB,I)=@I
 S TA(SUB,"DDBL")=+$G(DDBL)
 Q
 ;
SR(X,Y,ARRAY) ;Save, Restore, Array - Pass Array by reference **
 D INIT(X,.ARRAY)
 S X=""
 F  S X=$O(ARRAY(Y,X)) Q:X=""  S @X=ARRAY(Y,X)
 S ARRAY=Y  ;* * active array * *
 Q
 ;
FULL(TA) ;Full Screen
 ;TA passed by reference
 I TA=1 S DDBL=DDBL+(DDBSRL+2)
 N I,X
 F I="IOBM","IOTM","DDBSY","DDBSRL" S @I=TA(0,I)
 S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
 S I=1 D ETA
 W @IOSTBM
 S TA=0  ;* * active array * *
 S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL
 D PSR^DDBR0(1)
 Q
 ;
SPLIT ;Split Screen
 N I
 F I="IOBM","IOTM","DDBSY","DDBSRL" S @I=DDBRSA(2,I)
 S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
 S I=1
 D INIT("",.DDBRSA)
 W @IOSTBM
 S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL
 D PSR^DDBR0(1)
 D SR(2,1,.DDBRSA)
 W @IOSTBM
 S DDBL=DDBL-(DDBSRL+2),DDBRSA(1,"DDBL")=DDBL
 S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL
 D PSR^DDBR0(1)
 Q
 ;
 ;;NOTE: DDBRSA=0 - full screen
 ;;      DDBRSA=1 - top of split screen
 ;;      DDBRSA=2 - bottom of split screen

DDBRT
DDBRT ;SFISC/DCL-BROWSER TEST ROUTINE ;04:31 PM  11 Oct 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
TEST() ;TEST IF CRT CAN USE BROWSER;USER MUST GO THRU ZU OR XUP FIRST
 Q:$G(IOST(0)) $$GET(+IOST(0))
 Q:$G(IOS) $$GET($$GET1^DIQ(3.5,+IOS,"SUBTYPE","I"))
 Q:$G(^XUTL("XQ",$J,"IOST(0)")) $$GET(+^("IOST(0)"))
 Q:$G(^XUTL("XQ",$J,"IOS")) $$GET($$GET1^DIQ(3.5,+^("IOS"),"SUBTYPE","I"))
 Q 0
GET(DDBRTIEN) ;
 I $$GET1^DIQ(3.2,DDBRTIEN,"SET TOP & BOTTOM MARGINS")="" Q 0
 I $$GET1^DIQ(3.2,DDBRTIEN,"REVERSE INDEX")="" Q 0
 Q 1

DDBRU
DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;09:47 AM  1 Dec 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CTRLCH() ;Extrinsic function - returns control characters 1-31
 N I,X S X="" N I F I=1:1:31 S X=X_$C(I)
 Q X
 ;
COL(DDBC) ;Set up colums used by Fileman Print Set DIOEND="D COL^DDBRU()" when calling Browser
 N H,I,P,Q,T,X
 S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)")
 I $D(^TMP("DDBC",$J)) K ^($J)
 S X=0 F  S X=$O(^UTILITY($J,99,X)) Q:X'>0  S T=^(X) D
 .S:T["D ^" H=$P(T,"^",2)
 .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)=""
 .Q
 I $G(H)]""  F X=1:1 S T=$T(@"HEAD"+X^@H) Q:T=""  D
 .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)=""
 .Q
 Q
 ;
KTMP K ^TMP("DDB",$J),^TMP("DDBC",$J)
 K ^TMP("DDBLST",$J)
 Q
 ;
TRMERR(DDGLCH) ;Terminal type errors
 N P
 S P(1)=DDGLCH,P(2)=IOST
 D BLD^DIALOG(842,.P)
 Q
 ;
RTN(RTN,TMPGBL) ;
 N I,F,X
 F I=1:1 S X=$T(+I^@RTN) Q:X=""  S F=$F(X," ")-1,$E(X,F)=$E("        ",1,$S(F'>8:8-F,1:1)),@TMPGBL@(I)=$TR(X,$C(9)," ")
 Q
 ;
RTNTB(DDBRTOP,DDBRBOT) ;PASS TOP AND BOTTOM MARGINS
 G DR
 ;
ENDR N DDBENDR S DDBENDR=1
 ;
DR ;Display Routine(s)
 N DESC,RN,RSA,RTN,X,Y
 K ^TMP($J,"DDBDR"),^TMP($J,"DDBDRL"),^UTILITY($J)  ;DR LIST
 X ^%ZOSF("RSEL") Q:$O(^UTILITY($J,""))']""
 S RTN="",RN=1 F  S RTN=$O(^UTILITY($J,RTN)) Q:RTN=""  D
 .S DESC=$P($P($T(+1^@RTN),";",2),"-",2),DESC=$S($L(DESC)>45:$E(DESC,1,45)_"...",1:DESC)
 .S RSA=$NA(^TMP($J,"DDBDR",RN)),RN=RN+1,^TMP($J,"DDBDRL",RTN_$E("        ",1,8-$L(RTN))_": "_DESC)=RSA
 .W !,"...loading ",RTN
 .D RTN^DDBRU(RTN,RSA)
 .Q
 W !,"...building ""Current List"" tables"
 D DOCLIST^DDBR("^TMP($J,""DDBDRL"")","",$G(DDBRTOP),$G(DDBRBOT))
K K ^TMP($J,"DDBDRL"),^TMP($J,"DDBDR"),^UTILITY($J)
 Q
 ;
OUT ;
 D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
 D:$G(DDBFLG)'["P" KTMP
 Q
 ;
RE(DDBRTN) G EDIT
RTNEDIT N DDBRTN
EDIT ;ROUTINE EDIT VIA VA FILEMAN SCREEN EDITOR
 ;EITHER PASS ROUTINE NAME RE^DDBRU("ROUTINE_NAME") OR USE
 ;RTNEDIT^DDBRU AND BE PROMPTED FOR ROUTINE NAME
 I '$D(^DD("OS",^DD("OS"),"ZS")) W !,"ROUTINE SAVE NODE NOT DEFINED IN MUMPS OPERATING SYSTEM FILE",! Q
 N DDBRI,DDBRX,X,Y,%,%X,%Y
 I $G(DDBRTN)]"" S X=DDBRTN X ^%ZOSF("TEST") I '$T W !,DDBRTN," Invalid",!
 X ^%ZOSF("EON")
 R:$G(DDBRTN)="" !,"Enter Routine> ",DDBRTN:DTIME
 I DDBRTN="" W !,"NO ROUTINE SELECTED",! Q
 S X=DDBRTN X ^%ZOSF("TEST")
 I '$T W !,"NO SUCH ROUTINE",! Q
 K ^TMP("DDBRTN",$J)
 W !,"Loading ",DDBRTN
 F DDBRI=1:1 S DDBRX=$T(+DDBRI^@DDBRTN) Q:DDBRX=""  S ^TMP("DDBRTN",$J,DDBRI)=$$SP(DDBRX)
 D EDIT^DDW("^TMP(""DDBRTN"",$J)","M",DDBRTN,"Routine: "_DDBRTN)
 K ^UTILITY($J,0)
 S DDBRI=0,$P(^TMP("DDBRTN",$J,1),";",3)=$$NOW
 F  S DDBRI=$O(^TMP("DDBRTN",$J,DDBRI)) Q:DDBRI'>0  S ^UTILITY($J,0,DDBRI)=$$TAB(^(DDBRI))
 S X=DDBRTN
 X ^DD("OS",^DD("OS"),"ZS")
 K ^TMP("DDBRTN",$J),^UTILITY($J,0)
 X ^%ZOSF("EON")
 Q
TAB(X) ;CONVERT 1ST SPACE TO TAB IF NO TAB
 N E,L,T
 S X=$G(X)
 Q:X="" ""
 S T=$C(9)
 Q:$E(X)=T X
 S L=$L(X)
 F E=1:1:L Q:$E(X,E)=T  I $E(X,E)=" " S $E(X,E)=T D  Q
 .S E=E+1
 .F  Q:$E(X,E)'=" "  S $E(X,E)=""
 .Q
 Q X
 ;
SP(X) ;MAKE SURE A TAB OR 1ST SPACE IS SET TO SPACES
 N E,L,S,SPS,T
 S X=$G(X)
 Q:X="" ""
 S S=8,$P(SPS," ",S)=" ",T=$E(9)
 I $E(X)=T S $E(X)=" "  ;Q "       "_X
 S L=$L(X)
 F E=1:1:L I $E(X,E)=" " D  S $E(X,E)=$E(SPS,1,S-(E#S)) Q
 .S E=E+1
 .F  Q:$E(X,E)'=" "  S $E(X,E)=""
 .S E=E-1
 .Q
 Q X
 ;
NOW() ;
 N %DT,X,Y
 S %DT="T",X="NOW"
 D ^%DT
 Q $$FMTE^DILIBF(Y,"1U")
 ;
MSMCON ;MSM CONSOLE FOR 132/80 MODES
 ;OR VT TERMINALS
80 W *27,"[?",3,*108
 S (IOM,X)=80 X ^%ZOSF("RM")
 Q
132 W *27,"[?",3,*104
 S (IOM,X)=132 X ^%ZOSF("RM")
 Q

DDBRU2
DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS;12:54 PM  20 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
EN N DDBNCC G CNTNU
ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
CNTNU K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
 ;W !!,"Enter Root> " R DDBROOT W !!
 ;I DDBROOT="^"!(DDBROOT="") Q
 D ARSEL
 I $O(^TMP("DDBARDL",$J,""))']"" Q
 N DDBARDX,N,X
 S DDBARDX="",DDBNCC=$G(DDBNCC,1000)
 F  S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX=""  S X=^(DDBARDX) D
 .S N=$O(^TMP("DDBARD",$J,""),-1)+1
 .S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N))
 .W !,"...loading ",DDBARDX
 .D BLD(DDBNCC,X,N)
 .Q
 W !,"...building ""Current List"" tables"
 D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT))
END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
 Q
 ;
BLD(DDBNCC,DDBROOT,DDBN) ;build structures
 N DDBMAXL,DDBR1X
 S DDBMAXL=$G(DDBMAXL,255)
 S DDBNCC=$G(DDBNCC,1000)
 S DDBR1X=$$OREF^DIQGU(DDBROOT)
 N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT
 S DDBR1A=$$R^%RCR(DDBR1X),DDBR1Q=""""""
 I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))=""
 S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0
 F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="")  D  Q:DDBII
 .I '(DDBI#DDBNCC) D
 ..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes  "
 ..R DDBX:$G(DTIME,300) W !!
 ..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q
 ..S DDBII=1
 ..Q
 .S DDBX1=DDBR1
 .S DDBX3=@DDBR1
 .S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3)
 .S DDBXT=DDBX1L+DDBX2L+DDBX3L
 .I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q
 .I DDBX1L+DDBX2L'>DDBMAXL D  Q
 ..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L))
 ..S DDBI=DDBI+1
 ..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL)
 ..Q
 .Q
 Q
 ;
ARSEL ; Array Root Select
 N DDBERR,DDBRLVD,X,Y
 W !!
SEL R !,"Select Root> ",X:$G(DTIME,300)
 I X="" Q
 I X="^" K ^TMP("DDBARDL",$J) Q
 I $E(X)="?" D HLP G SEL
 I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL
 S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7),"  ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL
 S DDBRLVD=$$CREF^DIQGU(Y)
 S Y=$$CREF^DIQGU(X)
 I $D(@Y)'>9 S Y=$X W $C(7),"  ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL
 I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]"
 S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y
 G SEL
 ;
HLP ;
 W !!,"Enter a valid local or global array root"
 W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
 Q
R(%R) ;
 N %C,%F,%G,%I,%R1,%R2
 S %R1=$P(%R,"(")_"("
 I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D  Q:$G(DDBERR) %R
 .I $L(%R2)'>0 S DDBERR=1 Q
 .I %R2="%" Q
 .I $E(%R2)="%" D  Q
 ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
 ..Q
 .I %R2?1N.E S DDBERR=1 Q
 .I %R2?.E1P.E S DDBERR=1 Q
 .Q
 .;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R
 I $E(%R1)'="^" S %R2=$P(%R1,"(") D  Q:$G(DDBERR) %R
 .I $L(%R2)'>0 S DDBERR=1 Q
 .I %R2="%" Q
 .I $E(%R2)="%" D  Q
 ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
 ..Q
 .I %R2?1N.E S DDBERR=1 Q
 .I %R2?.E1P.E S DDBERR=1 Q
 .Q
 .;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R
 I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
 S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
 S %C=$L(%R2,","),%F=1 F %I=1:1 Q:%I'<%C  S %G=$P(%R2,",",%F,%I) Q:%G=""  I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) D
 .S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1)
 .Q
 S DDBERR=%F'=%C
 Q %R1_%R2
S(%Z) ;
 I $G(%Z)']"" Q ""
 I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
 I +%Z=%Z Q %Z
 I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z
 I %Z="""""" Q ""
 I $E(%Z)="""" Q %Z
 I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z
 I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
 I $D(@%Z) Q $$Q(@%Z)
 S DDBERR=1  ;Unable to resolve a variable within a reference
 Q %Z
Q(%Z) ;
 S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)

DDBRZIS
DDBRZIS ;SFISC/DCL-BROWSER DEVICE UTILITIES ;06:25 AM  7 Feb 1995;
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
OPEN ;
 ;DDBRZIS AND DDBDMSG ARE KILLED IN POST
 S DDBRZIS=1,DDBDMSG=$G(DDBDMSG)
 U IO(0)
 W !,"...one moment..."
 U IO
 Q:DDBDMSG]""
 I $G(DHD)="W """" D ^DIDH" S DDBDMSG="DATA DICTIONARY" Q
 S DDBDMSG="VA FileMan Browser"
 Q
 ;
CLOSE ;
 S DDBRZIS=$G(DDBRZIS,1)
 N C,CHAR,DDBROS,EOF,X
 K ^TMP("DDB",$J)
 S DDBROS=^%ZOSF("OS"),EOF="EOF-End Of File"
 S CHAR="" F I=1:1:31 S CHAR=CHAR_$C(I)
 U IO W !,EOF,!
 S DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR)
 I 'DDBRZIS("REWIND") S DDBRZIS=0 U IO(0) W $C(7),!!?5,"<< UNABLE TO REWIND FILE>>",! H 3 Q
 U IO
 S C=0
 F  R X:1 Q:X="EOF-End Of File"  D
 .S X=$TR(X,CHAR)
 .S:X']"" X=" "
 .S C=C+1,^TMP("DDB",$J,C)=$E(X,1,255) Q
 .Q
 Q
 ;
POST ;
 ;DDBRZIS IS KILLED IN DDBR
 I $G(DDBRZIS) D BROWSE^DDBR("^TMP(""DDB"",$J)","NR",$G(DDBDMSG))
 K DDBRZIS,DDBDMSG
 Q
 ;
STR(X) ;  Remove windows
 N I,Y
 I $L(X,"|")'>2 Q X
 I X["|WRAP|"!(X["| NO WRAP|")!(X["|NOWRAP|") S Y="" F I=1:1:$L(X,"|") S:(I#2) Y=Y_$P(X,"|",I)
 Q $S(X'["|":X,1:$G(Y))

DDGF
DDGF ;SFISC/MKO-FORM BUILDING TOOL ;08:38 AM  12 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;Program-wide variables
 ; DDGFILE  = File number^File name
 ; DDGFFM   = Form number^Form name
 ; DDGFPG   = Page number
 ; DDGFWID  = Window id for given page
 ; DDGFWIDB = Window id for block displayer for a given page
 ; DDGFREF  = Global reference where data is stored
 ; DDGFLIM  = Boundaries within which cursor can be moved
 ;            $Y1^$X1^$Y2^$X2
 ; DDGFBV   = If defined, we're in the block view page
 ; DDGFMSG  = Indicates there's a message on the message line.
 ;
 N %,%W,%X,%Y,C,D,D0,DI,DIC,DIEQ,DIW,DIZ,DQ,I,X,Y,DIOVRD
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 D ^DDGF0 G:$G(DIERR) END^DDGF0
 D SEL^DDGFFM G:$D(DDGFFM)[0 END^DDGF0
 D ALL^DDGFASUB,^DDGF1,END^DDGF0
 Q
 ;
REFRESH ;Repaint all windows, status line
 D REPALL^DDGLIBW(),STATUS
 Q
 ;
STATUS ;Paint status line
 N DX,DY,N,S
 K DDGFMSG
 S DY=IOSL-7,DX=0 X IOXY
 W $P(DDGLCLR,DDGLDEL,3)_$TR($J("",IOM-1)," ","_")
 ;
 S DY=IOSL-6 X IOXY
 W "File: "_$P(DDGFFILE,U,2)_" (#"_$P(DDGFFILE,U)_")"
 I $D(DDGFBV)#2 S DX=46 X IOXY W "BLOCK VIEWER"
 W !,"Form: "_$P(DDGFFM,U,2)
 S N=$G(@DDGFREF@("F",+$G(DDGFPG)))
 W !,"Page: "_$S(N]"":$P(N,U,6)_" ("_$P(N,U,5)_")",1:""),!!!
 I $D(DDGFBV)#2 W $P(DDGLVID,DDGLDEL)_"<PF1>V=Main Screen  <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
 E  W $P(DDGLVID,DDGLDEL)_"<PF1>Q=Quit  <PF1>E=Exit  <PF1>S=Save  <PF1>V=Block Viewer  <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
 Q
 ;
MSG(M) ;Print message
 N DDGFDY,DDGFDX
 S DDGFDY=DY,DDGFDX=DX S:$D(M)[0 M=""
 S DY=IOSL-2,DX=0 X IOXY
 ;
 W $E(M,1,79)_$P(DDGLCLR,DDGLDEL)
 S:M]"" DDGFMSG=1 K:M="" DDGFMSG
 S DY=DDGFDY,DX=DDGFDX X IOXY
 Q
 ;
RESET ;Reset terminal and cleanup
 S DDGFREF="^TMP(""DDGF"",$J)",DDGLREF="^TMP(""DDGL"",$J)"
 K DDSFILE,DDSPAGE,DDSPARM,DR
 G KILL^DDGF0

DDGF0
DDGF0 ;SFISC/MKO-SETUP, CLEANUP ;09:58 AM  9 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 D INIT^DDGLIB0() Q:$G(DIERR)
 D SET,GETKEY
 Q
 ;
SET ;Setup variables
 D:$D(DT)[0 DT^DICRW
 S (DIOVRD,DDGFR)=1,DDGFREF="^TMP(""DDGF"",$J)",DDGFCHG=0
 K @DDGFREF,DDGFFM
 Q
 ;
END ;Clear screen, clean up variables
 I $D(DDGFFM)#2 D RECOMP
KILL ;
 D:$G(DIERR) MSG^DIALOG("BW")
 X:$D(DDGLZOSF) DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
 D KILL^DDGLIB0()
 K:$D(DDGFREF) @DDGFREF,DDGFREF
 K ^TMP("DDGFH",$J)
 K DDGF,DDGFBV,DDGFCHG,DDGFE,DDGFFILE,DDGFFM,DDGFLIM,DDGFMSG
 K DDGFPG,DDGFR,DDGFWID,DDGFWIDB
 K DDH
 Q
 ;
RECOMP ;Recompile form
 N DDGFLIST
 S DDGFLIST=$NA(^TMP("DDGFOF",$J))
 D MSG^DDGF("Recompiling ...")
 ;
 D GETBLKS(+DDGFFM,DDGFLIST)
 S DDSQUIET=1 D EN^DDSZ(DDGFFM) K DDSQUIET
 I $D(@DDGFLIST) D
 . N DDGFI
 . S DDGFI=""
 . F  S DDGFI=$O(@DDGFLIST@(DDGFI)) Q:'DDGFI  D EN^DDSZ(DDGFI)
 . K @DDGFLIST
 ;
 D MSG^DDGF("")
 S DX=0,DY=IOSL-1 X IOXY
 Q
 ;
GETBLKS(F,L) ;
 ;Determine if any of the blocks loaded are
 ;used on other forms.
 ; L(Form#)=""        Other forms that need recompiling
 ;
 N P,B
 S P=0 F  S P=$O(@DDGFREF@("F",P)) Q:'P  D
 . S B=0
 . F  S B=$O(@DDGFREF@("F",P,B)) Q:'B  D:'$D(@L@("B",B))
 .. S @L@("B",B)=""
 .. D OTHER(B,F,L)
 K @L@("B")
 Q
 ;
OTHER(B,F,L) ;
 ;Return list L of forms other than F that use block B
 ; L(Form#)=""
 N F1
 S F1=""
 F  S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1=""  I F1'=F S @L@(F1)=""
 S F1="" F  S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1=""  I F1'=F S @L@(F1)=""
 Q
 ;
GETKEY ;Get key sequences and defaults
 N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T
 S AU=$P(DDGLKEY,U,2)
 S AD=$P(DDGLKEY,U,3)
 S AR=$P(DDGLKEY,U,4)
 S AL=$P(DDGLKEY,U,5)
 S F1=$P(DDGLKEY,U,6)
 S F2=$P(DDGLKEY,U,7)
 S F3=$P(DDGLKEY,U,8)
 S F4=$P(DDGLKEY,U,9)
 ;
 F N="","S","D" D
 . S DDGF(N_"IN")="",DDGF(N_"OUT")=""
 . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T=""  D
 .. S @("K="_$P(T,";",2))
 .. I DDGF(N_"IN")'[(U_K) D
 ... S DDGF(N_"IN")=DDGF(N_"IN")_U_K
 ... S DDGF(N_"OUT")=DDGF(N_"OUT")_$P(T,";")_U
 . S DDGF(N_"IN")=DDGF(N_"IN")_U
 . S DDGF(N_"OUT")=$E(DDGF(N_"OUT"),1,$L(DDGF(N_"OUT"))-1)
 Q
 ;
MAP ;Keys for main screen
 ;;LNU;AU;          line up
 ;;LND;AD;          line down
 ;;CHR;AR;          char right
 ;;CHL;AL;          char left
 ;;ELR;$C(9);       element right
 ;;ELL;"Q";         element left
 ;;TBR;"S";         tab right
 ;;TBL;"A";         tab left
 ;;EXIT;F1_"E";     exit
 ;;QUIT;F1_"Q";     quit
 ;;ROWCOL;"R";      row/col indicator toggle
 ;;SCT;F1_AU;       top of screen
 ;;SCB;F1_AD;       bottom of screen
 ;;SCR;F1_AR;       right edge of screen
 ;;SCL;F1_AL;       left edge of screen
 ;;SAVE;F1_"S";     save changes
 ;;SELECT;" ";      select an element
 ;;SELECT;$C(13);   select an element
 ;;SELFILE;F1_1;    select file
 ;;VIEW;F1_"V";     view toggle
 ;;EDIT;F3;         edit caption or data length
 ;;FLDADD;F2_"F";   add a new field
 ;;BKADD;F2_"B";    add a new block
 ;;NXTPG;F1_F1_AD;  go to next page
 ;;PRVPG;F1_F1_AU;  go to previous page
 ;;CLSPG;F1_"C";    close popup page
 ;;PGSEL;F1_"P";    select another page
 ;;PGADD;F2_"P";    add a new page
 ;;PGEDIT;F4_"P";   edit page attributes
 ;;FMSEL;F1_"M";    select another form
 ;;FMADD;F2_"M";    add a new form
 ;;FMEDIT;F4_"M";   edit form attributes
 ;;HELP;F1_"H"
 ;;
SMAP ;Keys for moving selected gadgets
 ;;LNU;AU;          line up
 ;;LND;AD;          line down
 ;;CHR;AR;          char right
 ;;CHL;AL;          char left
 ;;TBR;$C(9);       tab right
 ;;TBR;"S";          "   "
 ;;TBL;"Q";         tab left
 ;;TBL;"A";          "   "
 ;;ROWCOL;"R";      row/col indicator toggle
 ;;SCT;F1_AU;       top of screen
 ;;SCB;F1_AD;       bottom of screen
 ;;SCR;F1_AR;       right edge of screen
 ;;SCL;F1_AL;       left edge of screen
 ;;SUBPG;F1_"D";    go into a multiples pop-up page
 ;;DESELECT;" ";    deselect an element
 ;;DESELECT;$C(13); deselect an element
 ;;EDIT;F4;         edit properties
 ;;REORDER;F1_"O" ; reorder fields in block
 ;;
DMAP ;Keys for changing data length
 ;;CHR;AR;          char right
 ;;CHL;AL;          char left
 ;;DONE;$C(13);     done
 ;;DONE;" ";        done
 ;;DONE;F3;         done
 ;;

DDGF1
DDGF1 ;SFISC/MKO-MAIN SCREEN ;02:46 PM  12 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$D(DDGFMSG) MSG^DDGF() D:$T(@Y)]"" @Y Q:DDGFE
 Q
 ;
LNU I DY>$P(DDGFLIM,U) D RC(DY-1,DX)
 Q
LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX)
 Q
CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1)
 Q
CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1)
 Q
 ;
ELR N Y,X
 S Y=DY,X=DX
 S X=$O(@DDGFREF@("RC",DDGFWID,Y,X))
 D:X=""
 . S Y=$O(@DDGFREF@("RC",DDGFWID,Y))
 . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""))
 . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,""))
 D:X]"" RC(Y,X)
 Q
ELL N Y,X
 S Y=DY,X=DX
 S X=$O(@DDGFREF@("RC",DDGFWID,Y,X),-1)
 D:X=""
 . S Y=$O(@DDGFREF@("RC",DDGFWID,Y),-1)
 . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""),-1)
 . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,""),-1)
 D:X]"" RC(Y,X)
 Q
 ;
TBR I DX<$P(DDGFLIM,U,4) D
 . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5))
 E  I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2))
 Q
TBL I DX>$P(DDGFLIM,U,2) D
 . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5))
 E  I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4))
 Q
 ;
SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX)
 Q
SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX)
 Q
SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4))
 Q
SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2))
 Q
 ;
SAVE ;Save data from DDGFREF
 I 'DDGFPG D ERR(110) Q
 G SAVE^DDGFSV
 ;
SELECT ;Select an item
 I 'DDGFPG D ERR(110) Q
 G SELECT^DDGFEL
 ;
EDIT ;Edit a caption or data length
 I 'DDGFPG D ERR(110) Q
 G EDIT^DDGFEL
 ;
FLDADD ;Add a new field to the form
 I 'DDGFPG D ERR(110) Q
 G ADD^DDGFFLDA
 ;
VIEW ;Go to block viewer
 I 'DDGFPG D ERR(110) Q
 I $O(@DDGFREF@("F",DDGFPG,""))="" D ERR(120) Q
 G ^DDGF3
 ;
BKADD ;Add a new block
 I 'DDGFPG D ERR(110) Q
 G ADD^DDGFBK
 ;
HBKADD ;Add a header block
 I 'DDGFPG D ERR(110) Q
 G ADD^DDGFHBK
 ;
NXTPG ;Go to next page
 I 'DDGFPG D ERR(110) Q
 D NXTPRV^DDGFPG(1) Q
 ;
PRVPG ;Go to previous page
 I 'DDGFPG D ERR(110) Q
 D NXTPRV^DDGFPG(-1) Q
 ;
CLSPG ;Close pop-up page
 G CLSPG^DDGFPG
 ;
PGSEL ;Select a new page
 I 'DDGFPG D ERR(110) Q
 G PGSEL^DDGFPG
 ;
PGADD ;Add a new page to the form
 G ADD^DDGFPG
 ;
PGEDIT ;Edit attributes of a page
 I 'DDGFPG D ERR(110) Q
 G EDIT^DDGFPG
 ;
FMSEL ;Select another form
 G SEL^DDGFFM
 ;
FMADD ;Add a new form
 G ADD^DDGFFM
 ;
FMEDIT ;Edit the form
 G EDIT^DDGFFM
 ;
HELP ;Invoke help screens
 G HLP^DDGFH
 ;
TO ;Time-out
 W $C(7)
 G QUIT
 ;
QUIT ;Exit from form designer
 I DDGLSCR>1 G CLSPG^DDGFPG
 S DDGFE=1
 Q
EXIT ;Save and exit
 I DDGLSCR>1 G CLSPG^DDGFPG
 S DDGFE=1
 G SAVE^DDGFSV
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N DDGFS
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W DDGFS_$J("",7-$L(DDGFS))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("IN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("IN")'[(U_S_U) Y=-1
 ;
 I DDGF("IN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("OUT"),U,$L($P(DDGF("IN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q
 ;
ERR(X) ;
 D MSG^DDGF($C(7)_$P($T(@X),";;",2,999)) H 3
 D MSG^DDGF()
 Q
110 ;;There are no pages on this form.  Use PF2-P to add a page.
120 ;;There are no blocks on this page.  Use PF2-B to add a block.

DDGF2
DDGF2 ;SFISC/MKO-ACTIONS FOR SELECTED FIELDS ;02:48 PM  12 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Input:
 ;  B  = internal block number
 ;  F  = internal field order
 ;  T  = type of element ("C" = caption, "D" = data)
 ;  C  = caption
 ;  C1 = $Y of caption
 ;  C2 = $X of caption
 ;  D  = data representation (underlines)
 ;  D1 = $Y of data
 ;  D2 = $X of data
 ;  L  = length of data
 ;  P1 = page $Y
 ;  P2 = page $X
 N DDGFE
 S DDGFE=0,DDGFLSV=DDGFLIM
 S DDGFLIM=$P(@DDGFREF@("F",DDGFPG,B),U,1,2)_U_$P(DDGFLIM,U,3,4)
 ;
 D PAINTS
 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE
 D END
 D:$G(DDGFSUBP) SUBPG1^DDGFPG
 Q
 ;
END ;Redraw the field
 S DDGFLIM=DDGFLSV K DDGFLSV
 Q:$D(^DIST(.404,B,40,F,0))[0
 ;
 S C3=C2+$L(C)-1
 I T="C",C]"" D
 . D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2)
 . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
 ;
 I $D(D) D
 . S D3=D2+L-1
 . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
 . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
 ;
 S @DDGFREF@("F",DDGFPG,B,F)=C1_U_C2_U_C3_U_C_U_$S($D(D):D1_U_D2_U_D3_U_L,1:"^^^")_U_1,DDGFCHG=1
 X IOXY
 Q
 ;
TO ;Time-out
 W $C(7)
 G DESELECT
 ;
DESELECT ;
 S DDGFE=1
 Q
 ;
LNU I T="C" Q:C1'>$P(DDGFLIM,U)
 I $D(D),D1'>$P(DDGFLIM,U) Q
 D REDRAW S:T="C" C1=C1-1
 S:$D(D) D1=D1-1
 S DY=DY-1
 D PAINTS
 Q
LND I T="C" Q:C1'<$P(DDGFLIM,U,3)
 I $D(D),D1'<$P(DDGFLIM,U,3) Q
 D REDRAW
 S:T="C" C1=C1+1
 S:$D(D) D1=D1+1
 S DY=DY+1
 D PAINTS
 Q
CHR I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
 I $D(D),D2+L>$P(DDGFLIM,U,4) Q
 D REDRAW S:T="C" C2=C2+1
 S:$D(D) D2=D2+1
 S DX=DX+1
 D PAINTS
 Q
CHL I T="C" Q:C2'>$P(DDGFLIM,U,2)
 I $D(D),D2'>$P(DDGFLIM,U,2) Q
 D REDRAW S:T="C" C2=C2-1
 S:$D(D) D2=D2-1
 S DX=DX-1
 D PAINTS
 Q
TBR N X
 I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
 I $D(D),D2+L>$P(DDGFLIM,U,4) Q
 D REDRAW
 I T="C" D
 . S X=$$MIN(5,$P(DDGFLIM,U,4)-(C2+$L(C)),$S($D(D):$P(DDGFLIM,U,4)-(D2+L)+1,1:""))
 . S C2=C2+X
 E  S X=$$MIN(5,$P(DDGFLIM,U,4)-(D2+L)+1)
 S:$D(D) D2=D2+X
 S DX=DX+X
 D PAINTS
 Q
TBL N X
 I T="C" Q:C2'>$P(DDGFLIM,U,2)
 I $D(D),D2'>$P(DDGFLIM,U,2) Q
 D REDRAW
 I T="C" D
 . S X=$$MIN(5,C2-$P(DDGFLIM,U,2),$S($D(D):D2-$P(DDGFLIM,U,2),1:""))
 . S C2=C2-X
 E  S X=$$MIN(5,D2-$P(DDGFLIM,U,2))
 S:$D(D) D2=D2-X
 S DX=DX-X
 D PAINTS
 Q
SCT N Y
 I T="C" Q:C1'>$P(DDGFLIM,U)
 I $D(D),D1'>$P(DDGFLIM,U) Q
 D REDRAW
 I T="C" S Y=$S('$D(D):C1,C1<D1:C1,1:D1)-$P(DDGFLIM,U),C1=C1-Y
 E  S Y=D1-$P(DDGFLIM,U)
 S:$D(D) D1=D1-Y
 S DY=DY-Y
 D PAINTS
 Q
SCB N Y
 I T="C" Q:C1'<$P(DDGFLIM,U,3)
 I $D(D),D1'<$P(DDGFLIM,U,3) Q
 D REDRAW
 I T="C" S Y=$P(DDGFLIM,U,3)-$S('$D(D):C1,C1>D1:C1,1:D1),C1=C1+Y
 E  S Y=$P(DDGFLIM,U,3)-D1
 S:$D(D) D1=D1+Y
 S DY=DY+Y
 D PAINTS
 Q
SCR N X
 I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4)
 I $D(D),D2+L>$P(DDGFLIM,U,4) Q
 D REDRAW
 I T="C" D
 . S X=$P(DDGFLIM,U,4)-$S('$D(D):C2+$L(C),C2+$L(C)>(D2+L):C2+$L(C),1:D2+L)+1
 . S C2=C2+X
 E  S X=$P(DDGFLIM,U,4)-(D2+L)+1
 S:$D(D) D2=D2+X
 S DX=DX+X
 D PAINTS
 Q
SCL N X
 I T="C" Q:C2'>$P(DDGFLIM,U,2)
 I $D(D),D2'>$P(DDGFLIM,U,2) Q
 D REDRAW
 I T="C" S X=$S('$D(D):C2,C2<D2:C2,1:D2)-$P(DDGFLIM,U,2),C2=C2-X
 E  S X=D2-$P(DDGFLIM,U,2)
 S:$D(D) D2=D2-X
 S DX=DX-X
 D PAINTS
 Q
EDIT ;
 G EDIT^DDGFFLD
SUBPG ;
 G SUBPG^DDGFPG
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N DDGFS
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W DDGFS_$J("",7-$L(DDGFS))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
REDRAW ;
 D:T="C" REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C2-P2)_U_1_U_$L(C))
 D:$D(D) REPAINT^DDGLIBW(DDGFWID,(D1-P1)_U_(D2-P2)_U_1_U_L)
 Q
 ;
PAINTS ;
 N Y,X
 S Y=DY,X=DX
 I T="C" S DY=C1,DX=C2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10)
 I $D(D) S DY=D1,DX=D2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(D,1,$$MIN(L,$P(DDGFLIM,U,4)-D2+1))_$P(DDGLVID,DDGLDEL,10)
 D RC(Y,X)
 Q
 ;
MIN(X,Y,Z) ;Return the minimum of two or three numbers
 N A
 S A=$S(X<Y:X,1:Y)
 Q:$G(Z)="" A
 Q $S(A<Z:A,1:Z)
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("SIN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("SIN")'[(U_S_U) Y=-1
 ;
 I DDGF("SIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("SOUT"),U,$L($P(DDGF("SIN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q

DDGF3
DDGF3 ;SFISC/MKO-Block Viewer Page ;02:49 PM  12 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Variables used:
 ;  DDGFBV      = flag indicating we're on block viewer page
 ;  DDGFORIG(B) = original $Y^original $X for all blocks that were
 ;                  selected, since they were potentially moved
 ;  DDGFEBV     = flag that can be set to exit block viewer page
 ;                  after a block has been selected
 ;
 N DDGFE
 S DDGFE=0,DDGFBV=1 K DDGFORIG,DDGFEBV
 ;
 D PAINT,RC(DY,DX)
 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y D:$D(DDGFMSG) MSG^DDGF() Q:DDGFE!$G(DDGFEBV)
 D CLEANUP
 Q
 ;
LNU I DY>$P(DDGFLIM,U) D RC(DY-1,DX)
 Q
LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX)
 Q
CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1)
 Q
CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1)
 Q
ELR N Y,X
 S Y=DY,X=DX
 F  D  Q:Y=""!(X]"")
 . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X))
 . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y))
 D:X]"" RC(Y,X)
 Q
ELL N Y,X
 S Y=DY,X=DX
 F  D  Q:Y=""!(X]"")
 . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X),-1)
 . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y),-1)
 D:X]"" RC(Y,X)
 Q
TBR I DX<$P(DDGFLIM,U,4) D
 . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5))
 E  I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2))
 Q
TBL I DX>$P(DDGFLIM,U,2) D
 . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5))
 E  I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4))
 Q
 ;
SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX)
 Q
SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX)
 Q
SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4))
 Q
SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2))
 Q
SELECT ;
 Q:'$D(@DDGFREF@("BKRC",DDGFWIDB,DY))
 G SELECT^DDGFBSEL
 ;
SAVE ;Save data
 G SAVE^DDGFSV
 ;
BKADD ;Add a new block
 G ADD^DDGFBK
 ;
HBKADD ;Add a header block
 G ADD^DDGFHBK
 ;
HELP ;Invoke help screens
 D ^DDGFH,REFRESH^DDGF,RC(DY,DX)
 Q
 ;
TO W $C(7)
QUIT ;
EXIT ;
VIEW S DDGFE=1
 Q
CLEANUP ;
 S DDGFDY=DY,DDGFDX=DX
 D CLOSE^DDGLIBW(DDGFWIDB,1)
 I $D(DDGFORIG) D
 . N A
 . S A=$$AREA^DDGLIBW(DDGFWID)
 . D DESTROY^DDGLIBW(DDGFWID,1)
 . D CREATE^DDGLIBW(DDGFWID,A,$P(@DDGFREF@("F",DDGFPG),U,3)]"")
 . D BLK^DDGFUPDB(.DDGFORIG)
 E  D OPEN^DDGLIBW(DDGFWID)
 S DY=IOSL-6,DX=46 X IOXY W $J("",13)
 S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"<PF1>Q=Quit  <PF1>E=Exit  <PF1>S=Save  <PF1>V=Block Viewer  <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
 D RC(DDGFDY,DDGFDX)
 K DDGFDY,DDGFDX,DDGFBV,DDGFEBV,DDGFORIG
 Q
 ;
PAINT ;Paint block displayer window
 N B,C,S,DY,DX
 D CLOSE^DDGLIBW(DDGFWID,1)
 S DY=IOSL-6,DX=46 X IOXY W "BLOCK VIEWER"
 S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"<PF1>V=Main Screen  <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
 I $$EXIST^DDGLIBW(DDGFWIDB) D FOCUS^DDGLIBW(DDGFWIDB) Q
 D CREATE^DDGLIBW(DDGFWIDB,$P(DDGFLIM,U,1,2)_U_($P(DDGFLIM,U,3)-$P(DDGFLIM,U,1)+1)_U_($P(DDGFLIM,U,4)-$P(DDGFLIM,U,2)+1),$P(@DDGFREF@("F",DDGFPG),U,3)]"")
 S B="" F  S B=$O(@DDGFREF@("F",DDGFPG,B)) Q:B=""  D
 . S C=@DDGFREF@("F",DDGFPG,B)
 . S S=$P(C,U,4)
 . S:$P(C,U,3)'<IOM S=$E(S,1,IOM-$P(C,U,2)-1)
 . D WRITE^DDGLIBW(DDGFWIDB,S,$P(C,U)-$P(DDGFLIM,U),$P(C,U,2)-$P(DDGFLIM,U,2))
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("IN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("IN")'[(U_S_U) Y=-1
 ;
 I DDGF("IN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("OUT"),U,$L($P(DDGF("IN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q

DDGF4
DDGF4 ;SFISC/MKO-ACTIONS AFTER BLOCK SELECTION ;02:49 PM  12 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Input:
 ;  B     = Block number
 ;  C     = Block name
 ;  C1    = Block $Y
 ;  C2    = Block $X1
 ;  C3    = Block $X2
 ;  DDGFHDR = 1, if block is immobile (header block)
 ;
 N DDGFE
 S:'$G(DDGFHDR) DDGFHDR=0
 D PAINTS
 ;
 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE
 D CLEANUP
 Q
 ;
LNU Q:C1'>$P(DDGFLIM,U)!DDGFHDR
 D REDRAW
 S C1=C1-1,DY=DY-1
 D PAINTS
 Q
LND Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR
 D REDRAW
 S C1=C1+1,DY=DY+1
 D PAINTS
 Q
CHR Q:C2'<$P(DDGFLIM,U,4)!DDGFHDR
 D REDRAW
 S C2=C2+1,DX=DX+1
 D PAINTS
 Q
CHL Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
 D REDRAW
 S C2=C2-1,DX=DX-1
 D PAINTS
 Q
TBR N X
 Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR
 D REDRAW
 S X=$$MIN(5,$P(DDGFLIM,U,4)-C2-$L(C)+1)
 S C2=C2+X,DX=DX+X
 D PAINTS
 Q
TBL N X
 Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
 D REDRAW
 S X=$$MIN(5,C2-$P(DDGFLIM,U,2))
 S C2=C2-X,DX=DX-X
 D PAINTS
 Q
SCT Q:C1'>$P(DDGFLIM,U)!DDGFHDR
 D REDRAW
 S (C1,DY)=$P(DDGFLIM,U)
 D PAINTS
 Q
SCB Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR
 D REDRAW
 S (C1,DY)=$P(DDGFLIM,U,3)
 D PAINTS
 Q
SCR N X
 Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR
 D REDRAW
 S X=$P(DDGFLIM,U,4)-C2-$L(C)+1
 S C2=C2+X,DX=DX+X
 D PAINTS
 Q
SCL N X
 Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR
 D REDRAW
 S X=C2-$P(DDGFLIM,U,2)
 S C2=C2-X,DX=DX-X
 D PAINTS
 Q
 ;
EDIT ;Edit block parameters
 G:'$G(DDGFHDR) EDIT^DDGFBK
 G EDIT^DDGFHBK
 ;
REORDER ;Reorder fields on block
 D EN^DDGFORD(B)
 Q
 ;
TO ;Time-out
 W $C(7)
 G DESELECT
 ;
DESELECT ;
 S DDGFE=1
 Q
 ;
CLEANUP ;
 I '$G(DDGFBDEL) D
 . S C3=C2+$L(C)-1
 . S @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1,DDGFCHG=1
 . S @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$S($G(DDGFHDR):"H",1:"")
 ;
 I '$G(DDGFEBV),'$G(DDGFBDEL) D
 . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2))
 . X IOXY
 K DDGFHDR,DDGFBDEL
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
REDRAW ;
 D REPAINT^DDGLIBW(DDGFWIDB,(C1-$P(DDGFLIM,U))_U_(C2-$P(DDGFLIM,U,2))_U_1_U_$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))
 Q
 ;
PAINTS ;
 N Y,X
 S Y=DY,X=DX
 S DY=C1,DX=C2 X IOXY
 W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10)
 D RC(Y,X)
 Q
 ;
MIN(X,Y,Z) ;Return the minimum of two or three numbers
 N A
 S A=$S(X<Y:X,1:Y)
 Q:$G(Z)="" A
 Q $S(A<Z:A,1:Z)
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("SIN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("SIN")'[(U_S_U) Y=-1
 ;
 I DDGF("SIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("SOUT"),U,$L($P(DDGF("SIN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q

DDGFADL
DDGFADL ;SFISC/MKO-ADJUST DATA LENGTH ;11:28 AM  22 Dec 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N DDGFE
 D DRAW(1)
 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE
 Q
 ;
CHR Q:L'<($P(DDGFLIM,U,4)-D2+1)
 S L=L+1,D=D_"_"
 D DRAW(1)
 Q
CHL Q:L<2
 S L=L-1,D=$E(D,1,$L(D)-1)
 D DRAW(-1)
 Q
DONE ;
 S DDGFE=1,D3=D2+L-1,DDGFDY=DY,DDGFDX=DX
 S DY=IOSL-6,DX=IOM-9
 X IOXY W $J("",7)
 S DY=DDGFDY,DX=DDGFDX X IOXY
 K DDGFDY,DDGFDX
 Q
DRAW(I) ;Draw line
 ;I = 1 if we've increased the data length, -1 if we've decreased it
 ;
 N S,X,Y
 S X=DX,Y=DY
 S DY=D1,DX=D2 X IOXY
 W $P(DDGLVID,DDGLDEL,6)_D_$P(DDGLVID,DDGLDEL,10)_$E(" ",1,I=-1)
 S DY=IOSL-6,DX=IOM-9,S="L="_L X IOXY W S_$J("",7-$L(S))
 I I=-1 D REPAINT^DDGLIBW(DDGFWID,D1_U_(D2+L)_U_1_U_1)
 ;
 S DX=X,DY=Y X IOXY
 Q
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("DIN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("DIN")'[(U_S_U) Y=-1
 ;
 I DDGF("DIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("DOUT"),U,$L($P(DDGF("DIN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q

DDGFAPC
DDGFAPC ;SFISC/MKO-ADJUST PAGE COORDINATES ;01:16 PM  19 Jan 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Input:
 ; T  = PTOP: top of page
 ;      PBRC: bottom right corner of page
 ;Returns:
 ; DDGFLIM
 ;
 N DDGFE,P1,P2,P3,P4
 ;
 D SETUP
 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE
 D CLEANUP
 Q
 ;
DESELECT ;
 S DDGFE=1
 Q
 ;
LNU Q:DY'>$P(DDGFLIM,U)
 D MV(DY-1,DX)
 Q
LND Q:DY'<$P(DDGFLIM,U,3)
 D MV(DY+1,DX)
 Q
CHR Q:DX'<$P(DDGFLIM,U,4)
 D MV(DY,DX+1)
 Q
CHL Q:DX'>$P(DDGFLIM,U,2)
 D MV(DY,DX-1)
 Q
TBR Q:DX'<$P(DDGFLIM,U,4)
 D MV(DY,DX+$$MIN(5,$P(DDGFLIM,U,4)-DX))
 Q
TBL Q:DX'>$P(DDGFLIM,U,2)
 D MV(DY,DX-$$MIN(5,DX-$P(DDGFLIM,U,2)))
 Q
SCT Q:DY'>$P(DDGFLIM,U)
 D MV($P(DDGFLIM,U),DX)
 Q
SCB Q:DY'<$P(DDGFLIM,U,3)
 D MV($P(DDGFLIM,U,3),DX)
 Q
SCR Q:DX'<$P(DDGFLIM,U,4)
 D MV(DY,$P(DDGFLIM,U,4))
 Q
SCL Q:DX'>$P(DDGFLIM,U,2)
 D MV(DY,$P(DDGFLIM,U,2))
 Q
 ;
MV(DDGFY,DDGFX) ;
 I T="PTOP" D
 . F DDGFC=P1_U_P2,P1_U_P4,P3_U_P2,P3_U_P4 D REPALL^DDGLIBW(DDGFC_"^1^1")
 . S P1=P1+DDGFY-DY,P2=P2+DDGFX-DX,P3=P3+DDGFY-DY,P4=P4+DDGFX-DX
 ;
 I T="PBRC" D
 . D:DDGFX'=DX REPALL^DDGLIBW(P1_U_P4_"^1^1")
 . D:DDGFY'=DY REPALL^DDGLIBW(P3_U_P2_"^1^1")
 . D REPALL^DDGLIBW(P3_U_P4_"^1^1")
 . S P3=P3+DDGFY-DY,P4=P4+DDGFX-DX
 ;
 D CORNER()
 S DY=DDGFY,DX=DDGFX
 K DDGFC
 Q
 ;
CORNER(N) ;Draw corners of box
 ;In: P1,P2,P3,P4,T; if N:normal video
 N DY,DX
 S DY=P1,DX=P2 X IOXY
 W $P(DDGLGRA,DDGLDEL)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,6))_$P(DDGLGRA,DDGLDEL,5)
 S DY=P1,DX=P4 X IOXY W $P(DDGLGRA,DDGLDEL,6)
 S DY=P3,DX=P2 X IOXY W $P(DDGLGRA,DDGLDEL,7)
 S DX=P4 X IOXY
 W $P(DDGLGRA,DDGLDEL,8)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,10))_$P(DDGLGRA,DDGLDEL,2)
 Q
 ;
MIN(X,Y,Z) ;Return the minimum of two or three numbers
 N A
 S A=$S(X<Y:X,1:Y)
 Q:$G(Z)="" A
 Q $S(A<Z:A,1:Z)
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
SETUP ;Initial setup
 S DDGFDY=DY,DDGFDX=DX
 ;
 ;Get page coordinates
 S P4=@DDGFREF@("F",DDGFPG)
 S P1=$P(P4,U),P2=$P(P4,U,2),P3=$P(P4,U,3),P4=$P(P4,U,4)
 S DDGFAREA=P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1)
 ;
 ;Draw corners in reverse video, reset DDGFLIM
 D CORNER()
 I T="PTOP" S DDGFLIM=0_U_(DX-P2)_U_(DY+IOSL-8-P3)_U_(DX+IOM-2-P4)
 I T="PBRC" S DDGFLIM=P1+2_U_(P2+2)_U_(IOSL-8)_U_(IOM-2)
 Q
 ;
CLEANUP ;Final cleanup
 I DDGFDY'=DY!(DDGFDX'=DX) D
 . D PAGE^DDGFUPDP(P1,P2,P3,P4,T,DDGFAREA)
 E  D CORNER(1) S DDGFLIM=P1_U_P2_U_P3_U_P4
 ;
 D RC(DY,DX)
 K DDGFDY,DDGFDX,DDGFAREA
 Q
 ;
READ() N S,Y
 F  R *Y:DTIME D C Q:Y'=-1
 Q Y
 ;
C I Y<0 S Y="TO" Q
 S S=""
C1 S S=S_$C(Y)
 I DDGF("SIN")'[(U_S) D  I Y=-1 W $C(7) Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("SIN")'[(U_S_U) Y=-1
 ;
 I DDGF("SIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("SOUT"),U,$L($P(DDGF("SIN"),U_S_U),U)) Q
 R *Y:5 G:Y'=-1 C1 W $C(7)
 Q

DDGFASUB
DDGFASUB ;SFISC/MKO-MANAGE "ASUB" ARRAY ;09:36 AM  29 Mar 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ALL ;Get subpages into @DDGFREF@("ASUB")
 N P,B S P=0
 F  S P=$O(^DIST(.403,+DDGFFM,40,P)) Q:'P  D:$P($G(^(P,1)),U,2)]"" ADD(P)
 Q
 ;
ADD(P) ;
 ;Setup @DDGFREF@("ASUB",pg,bk,ddo)=subpage P
 N MP,MB,MF,X
 S MF=$$UC($P(^DIST(.403,+DDGFFM,40,P,1),U,2)) Q:MF=""
 S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",")
 ;
 S MP=$O(^DIST(.403,+DDGFFM,40,$S(MP=+$P(MP,"E"):"B",1:"C"),MP,""))
 Q:MP=""
 ;
 I MB=+$P(MB,"E") D
 . S MB=$O(^DIST(.403,+DDGFFM,40,MP,40,"AC",MB,""))
 E  D
 . S MB=$O(^DIST(.404,"B",$$UC(MB),"")) Q:MB=""
 . S MB=$O(^DIST(.403,+DDGFFM,40,MP,40,"B",MB,""))
 Q:MB=""
 ;
 S X=$S(MF=+$P(MF,"E"):"B",$D(^DIST(.404,MB,40,"D",MF)):"D",1:"C")
 S MF=$O(^DIST(.404,MB,40,X,MF,"")) Q:MF=""
 S @DDGFREF@("ASUB",MP,MB,MF)=P,@DDGFREF@("ASUB","B",P,MP,MB,MF)=""
 Q
 ;
DEL(P) ;
 ;Delete subpage DDGFPG from @DDGFREF@("ASUB")
 Q:'$D(@DDGFREF@("ASUB","B",P))
 ;
 N MP,MB,MF
 S MP="" F  S MP=$O(@DDGFREF@("ASUB","B",P,MP)) Q:MP=""  D
 . S MB="" F  S MB=$O(@DDGFREF@("ASUB","B",P,MP,MB)) Q:MB=""  D
 .. S MF="" F  S MF=$O(@DDGFREF@("ASUB","B",P,MP,MB,MF)) Q:MF=""  D
 ... K @DDGFREF@("ASUB","B",P,MP,MB,MF),@DDGFREF@("ASUB",MP,MB,MF)
 Q
 ;
EDIT(P) ;
 ;Edit "ASUB" to reflect new parent page
 D DEL(P),ADD(P)
 Q
UC(X) ;
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDGFBK
DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 PM  13 Sep 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ADD ;Add a new block
 N B,C1,C2,C3
 S DDGFDY=DY,DDGFDX=DX
 ;
 ;Invoke form to enter block name
 K DDGFBNUM,DDGFBNAM
 D DDS(.404,"[DDGF BLOCK ADD]")
 G:'$D(DDGFBNUM) ADDQ
 ;
 ;Ask whether block should be added or indicate duplicate block
 K DDGFANS
 S DDSPAGE=$S($P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$D(^(40,"B",DDGFBNUM)):21,1:11)
 D DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
 G:DDSPAGE=21 ADDQ
 I '$G(DDGFANS) D  G ADDQ
 . I $D(^DIST(.404,DDGFBNUM,0))#2,'$P(^(0),U,2) D
 .. N DIK,DA
 .. S DIK="^DIST(.404,",DA=DDGFBNUM
 .. D ^DIK
 K DDSPAGE,DDGFANS
 ;
 ;Add block to page
 S DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,",DIC(0)="L"
 S DA(2)=+DDGFFM,DA(1)=DDGFPG
 S DIC("P")=$P(^DD(.4031,40,0),U,2)
 S (DINUM,X)=DDGFBNUM
 K DO,DD D FILE^DICN K DINUM,X
 G:Y=-1 ADDQ
 ;
 ;Stuff in values for block order, coordinates, and type
 S DIE=DIC,DA=+Y
 S DDGFC=DDGFDY-$P(DDGFLIM,U)+1_","_(DDGFDX-$P(DDGFLIM,U,2)+1)
 S DR="1////"_($O(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
 D ^DIE K DA,DIC,DIE,DR,X,Y,DDGFC
 ;
 ;If this looks like a brand new block, stuff in DD number
 I $L(^DIST(.404,DDGFBNUM,0),U)=1,'$O(^(0)) D
 . S DIE="^DIST(.404,",DA=DDGFBNUM
 . S DR="1////"_$P(^DIST(.403,+DDGFFM,0),U,8)
 . D ^DIE K DA,DIE,DR
 ;
 D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
 ;
 S DY=DDGFDY,DX=DDGFDX
 S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
 S C1=DY,C2=DX,C3=C2+$L(DDGFBNAM)-1
 S DDGFADD=1
 K DDGFBNUM,DDGFBNAM
 S:$G(DDGFBV) DDGFORIG(B)=DY_U_DX
 G EDIT
 ;
ADDQ ;Adding aborted
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 K DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
 Q
 ;
EDIT ;Edit block
 ;In: B,C1,C2,C3,C
 S DDGFDY=DY,DDGFDX=DX
 S DDGFBK=B,DDGFC1=C1,DDGFC2=C2,DDGFC3=C3
 S DDGFBKCO=C1-$P(DDGFLIM,U)+1_","_(C2-$P(DDGFLIM,U,2)+1)
 S DDGFBKNO=C
 ;
 ;Invoke form to edit block
 S DDSFILE=.403,DDSFILE(1)=.4032
 S DA(2)=+DDGFFM,DA(1)=DDGFPG,DA=B
 S DR="[DDGF BLOCK EDIT]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DA,DR,DDSPARM
 ;
 ;If block was deleted, remove data from DDGFREF
 I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0 D DELETE(DDGFBK) G EDITQ
 ;
 S:$D(DDGFBKCN)[0 DDGFBKCN=DDGFBKCO
 S:$D(DDGFBKNN)[0 DDGFBKNN=DDGFBKNO
 ;
 S C=DDGFBKNN
 S C1=$P(DDGFBKCN,",")-1+$P(DDGFLIM,U)
 S C2=$P(DDGFBKCN,",",2)-1+$P(DDGFLIM,U,2)
 S C3=C2+$L(C)-1
 ;
 ;Update TMP if coordinates or name changed, or new block
 I DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$G(DDGFADD) D
 . D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),DDGFC1-$P(DDGFLIM,U),DDGFC2-$P(DDGFLIM,U,2),"",1)
 . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
 ;
EDITQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 S:'$G(DDGFADD) DDGFE=1
 K DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
 K DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
 Q
 ;
DELETE(B,E) ;Remove block from DDGFREF
 ;E : means don't set DDGFEBV or DDGFBDEL
 ;    (used by EDIT^DDGFHBK when a different header block is chosen)
 N F,N
 ;Remove from TMP
 S F="" F  S F=$O(@DDGFREF@("F",DDGFPG,B,F)) Q:F=""  D
 . S N=@DDGFREF@("F",DDGFPG,B,F)
 . K:$P(N,U,4)]"" @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B)
 . K:$P(N,U,8)>0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B)
 K @DDGFREF@("F",DDGFPG,B)
 ;
 ;If no blocks on page, set DDGFEBV to exit Block Viewer
 ;DDGFBDEL indicates block name should not be painted
 I $G(DDGFBV) D:'$G(E)
 . I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1
 . S DDGFBDEL=1
 E  D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
 ;
 ;If used on no other forms, ask whether to delete from block file
 I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D
 . K DDGFANS S DDGFBK=B
 . D DDS(.404,"[DDGF BLOCK DELETE]")
 . I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA
 . K DDGFANS,DDGFBK
 Q
 ;
DDS(DDSFILE,DR,DA,DDSPAGE) ;
 ;Call DDS
 S DDSPARM="KTW" D ^DDS K DDSPARM
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFBSEL
DDGFBSEL ;SFISC/MKO-SELECT BLOCK ;07:50 AM  23 Aug 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Sets:
 ;  DDGFORIG(B) = original $Y^original $X for all blocks that were
 ;                  selected, since they were potentially moved
SELECT ;
 N B,C,C1,C2,C3
 N B1,X1,X2
 ;
 ;Which element is the cursor on?
 ;Set B=Block
 S X1="" K B
 F  S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1)) Q:X1=""!(DX<X1)  D
 . S X2=""
 . F  S X2=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2)) Q:X2=""  D  Q:$G(B)
 .. Q:DX>X2
 .. S B=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,""))
 .. I @DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,B)="H",$O(^(B)) S B=$O(^(B))
 Q:'$G(B)
 ;
 ;Get caption and coordinates
 S B1=$G(@DDGFREF@("F",DDGFPG,B)) Q:B1=""
 S C1=$P(B1,U),C2=$P(B1,U,2),C3=$P(B1,U,3),C=$P(B1,U,4)
 ;
 S:@DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)="H" DDGFHDR=1
 D COVER
 ;
 K B1,X1,X2
 G ^DDGF4
 ;
COVER ;
 N H,O,L
 ;Clear and/or kill portions of DDGFREF
 K @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)
 ;
 ;Remember original block coordinates
 S:$D(DDGFORIG(B))[0 DDGFORIG(B)=C1_U_C2
 ;
 ;Look for covered (hidden) fields
 ;Set H(B) - array of hidden fields
 S X1=""
 F  S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1)) Q:X1=""  D
 . S X2=""
 . F  S X2=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2)) Q:X2=""  D
 .. S H=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2,""))
 .. I H]"",$D(H(H))[0,$$OVERLAP(C2,C3,X1,X2) S H(H)=""
 ;
 ;Clear in buffer area occupied by element(s) selected
 ;If block on the page border, redraw the lines
 S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0))
 D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
 ;
 I $P(@DDGFREF@("F",DDGFPG),U,3) D
 . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D
 .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3))
 .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7))
 .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDE,$S(C1=$P(DDGFLIM,U):6,1:8))
 .. D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
 . E  I C2=$P(DDGFLIM,U,2) D
 .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
 . E  I C3'<$P(DDGFLIM,U,4) D
 .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1)
 ;
 ;Write to buffer the overlapped blocks(s)
 I $D(H)>1 S H="" F  S H=$O(H(H)) Q:H=""  D
 . S B1=$G(@DDGFREF@("F",DDGFPG,H)) Q:B1=""
 . D WRITE^DDGLIBW(DDGFWIDB,$P(B1,U,4),$P(B1,U)-$P(DDGFLIM,U),$P(B1,U,2)-$P(DDGFLIM,U,2),"",1)
 Q
 ;
OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2
 N T
 I A1<B1 S T=A1,A1=B1,B1=T,T=A2,A2=B2,B2=T
 Q A1'<B1&(A1'>B2)!(A2'<B1&(A2'>B2))

DDGFEL
DDGFEL ;SFISC/MKO-SELECT OR EDIT ELEMENT ;07:25 AM  7 Aug 1995
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
SELECT ;Select an element
 N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
 D GETELEM(DY,DX) Q:$G(F)=""
 ;
 I F="P" G ^DDGFAPC
 ;
 ;Clear and/or kill portions of DDGFREF
 S:T="D" $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
 K:T="C" @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C"),@DDGFREF@("F",DDGFPG,B,F)
 K:$D(D) @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")
 ;
 D COVER
 G ^DDGF2
 ;
EDIT ;Edit a caption or data length
 N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2,X,Y
 D GETELEM(DY,DX) Q:"P"[$G(F)
 ;
 S DDGFCHG=1
 I T="C" D
 . K D,D1,D2,D3,L
 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)="^^^"
 . K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")
 . D COVER
 . D
 .. N DX,DY
 .. S DY=IOSL-6,DX=IOM-9 X IOXY W "EDIT   "
 . ;
 . N DDGFCOD,DDGFX
 . D EN^DIR0(C1,C2,$L(C),1,C,"","","","KWT",.DDGFX,.DDGFCOD)
 . S X=DDGFX
 . I $P(DDGFCOD,U)="TO"!(X="!M") W $C(7) S X=C
 . E  I X["^" S X=C
 . E  X $P(^DD(.4044,1,0),U,5,999) I '$D(X) W $C(7) S X=C
 . S C3=C2+$L(X)-1
 . ;
 . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
 . D WRITE^DDGLIBW(DDGFWID,X,C1-P1,C2-P2)
 . I $L(X)<$L(C) D REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C3+1-P2)_U_1_U_($L(C)-$L(X)))
 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)=C1_U_C2_U_C3_U_X,$P(^(F),U,9)=1
 ;
 I T="D" D
 . K C,C1,C2,C3
 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=""
 . K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F)
 . D COVER,^DDGFADL
 . ;
 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=D1_U_D2_U_D3_U_L,$P(^(F),U,9)=1
 . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
 . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2)
 ;
 D RC(DY,DX)
 Q
 ;
GETELEM(DY,DX) ;Which element is the cursor on
 ;Returns P,B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2
 ;If on pop-up page border, return only B="P",F="P",T="PTOP" or "PBRC"
 ;Set P=page,B=Block,F=DDO,T=type ("D" or "C")
 ;If cursor is not on anything, $G(F)=""
 ;
 Q:'$D(@DDGFREF@("RC",DDGFWID,DY))
 N X1,X2,F1
 S X1="" K F
 F  S X1=$O(@DDGFREF@("RC",DDGFWID,DY,X1)) Q:X1=""!(DX<X1)  D
 . S X2=""
 . F  S X2=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2)) Q:X2=""  D  Q:$G(F)
 .. Q:DX>X2
 .. S B=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,""))
 .. S F=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,""))
 .. S T=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,F,""))
 Q:"P"[$G(F)
 ;
 S P1=$P(DDGFLIM,U),P2=$P(DDGFLIM,U,2)
 S F1=$G(@DDGFREF@("F",DDGFPG,B,F))
 ;
 ;Get caption, data, and coordinates
 S C1=$P(F1,U),C2=$P(F1,U,2),C3=$P(F1,U,3),C=$P(F1,U,4)
 I $P(F1,U,8)]"" D
 . S D1=$P(F1,U,5),D2=$P(F1,U,6),D3=$P(F1,U,7)
 . S L=$P(F1,U,8),D=$TR($J("",L)," ","_")
 Q
 ;
COVER ;Look for covered (hidden) fields
 ;Input:
 ; T,C,C1,C2,P1,P2
 ;H(DDO) - array of hidden fields
 ;Erase the element we've selected from buffer
 ;Redraw the element(s) that were covered
 N H,O,X1,X2,Y
 F Y="C1","D1" D
 . I Y="C1",T'="C" Q
 . I Y="D1",'$D(D) Q
 . S X1=""
 . F  S X1=$O(@DDGFREF@("RC",DDGFWID,@Y,X1)) Q:X1=""  D
 .. S X2=""
 .. F  S X2=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2)) Q:X2=""  D
 ... N B
 ... S B=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,""))
 ... S O=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,B,""))
 ... I O]"",$D(H(O))[0 D
 .... I T="C",$$OVERLAP(C2,C3,X1,X2) S H(O)=DDGFPG_U_B
 .... E  I $D(D),$$OVERLAP(D2,D3,X1,X2) S H(O)=DDGFPG_U_B
 ;
 ;Clear in buffer area occupied by element(s) selected
 D:T="C" CLEAR(C,C1,C2,C3)
 D:$D(D) CLEAR(D,D1,D2,D3)
 ;
 ;Write to buffer the overlapped field(s)
 I $D(H) S H="" F  S H=$O(H(H)) Q:H=""  D
 . S O=$G(@DDGFREF@("F",$P(H(H),U),$P(H(H),U,2),H)) Q:O=""
 . D WRITE^DDGLIBW(DDGFWID,$P(O,U,4),$P(O,U)-P1,$P(O,U,2)-P2,"",1)
 . I $P(O,U,8)>0 D WRITE^DDGLIBW(DDGFWID,$TR($J("",$P(O,U,8))," ","_"),$P(O,U,5)-P1,$P(O,U,6)-P2,"",1)
 Q
 ;
OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2
 N T
 I A1<B1 S T=A1,A1=B1,B1=T,T=A2,A2=B2,B2=T
 Q A1'<B1&(A1'>B2)!(A2'<B1&(A2'>B2))
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q
 ;
CLEAR(C,C1,C2,C3) ;Clear in buffer area occupied by element(s) selected
 ;If on the page border, redraw the lines
 N L
 S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0))
 D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
 ;
 I $P(@DDGFREF@("F",DDGFPG),U,3) D
 . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D
 .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3))
 .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7))
 .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):6,1:8))
 .. D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
 . E  I C2=$P(DDGFLIM,U,2) D
 .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1)
 . E  I C3'<$P(DDGFLIM,U,4) D
 .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1)
 Q

DDGFFLD
DDGFFLD ;SFISC/MKO-EDIT A FIELD ;01:47 PM  22 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EDIT ;
 Q:$D(^DIST(.404,B,40,F,0))[0
 I T="D" Q:C]""  K @DDGFREF@("F",DDGFPG,B,F)
 ;
 S DDGFDY=DY,DDGFDX=DX
 S DDGFTYPE=$P(^DIST(.404,B,40,F,0),U,3)
 I 'DDGFTYPE D
 . I $G(^DIST(.404,B,40,F,20))'?."^" S DDGFTYPE=2 Q
 . I $P($G(^DIST(.404,B,0)),U,2),$G(^DIST(.404,B,40,F,1)) S DDGFTYPE=3
 G:'DDGFTYPE EDITQ
 ;
 S DDGFB2=@DDGFREF@("F",DDGFPG,B)
 S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2)
 S DDGFDD=$P(^DIST(.404,B,0),U,2)
 S (DDGFSUP,DDGFSUP0)=$S(C]""&(DDGFTYPE'=1):$E(C,$L(C))'=":",1:"")
 S (DDGFCAP,DDGFCAP0)=$S(DDGFTYPE=1!DDGFSUP0:C,1:$E(C,1,$L(C)-1))
 S (DDGFCC,DDGFCC0)=$S(C]"":C1-DDGFB1+1_","_(C2-DDGFB2+1),1:"")
 I $D(D) D
 . S (DDGFDL,DDGFDL0)=L
 . S (DDGFDC,DDGFDC0)=D1-DDGFB1+1_","_(D2-DDGFB2+1)
 K DDGFB1,DDGFB2
 ;
 S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="KSTW"
 S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]"
 S DA=F,DA(1)=B
 D
 . N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2
 . D ^DDS K DDSFILE,DDSPARM,DR,DDGFDD
 ;
 ;If caption, caption coords, data length, data coords, or suppress
 ;colon flag changed we need to update some local variables
 I $D(DA)#2,$G(DDSSAVE) D
 . S DDGFNDB=$G(@DDGFREF@("F",DDGFPG,B))
 . S:DDGFCAP="" (DDGFSUP,DDGFCC)=""
 . S DR=""
 . ;
 . I DDGFCAP'=DDGFCAP0!(DDGFSUP'=DDGFSUP0) D
 .. S C=DDGFCAP_$S(DDGFCAP]""&(DDGFTYPE'=1)&'DDGFSUP:":",1:"")
 .. S:DDGFCAP'=DDGFCAP0 DR=DR_"1////"_$S(DDGFCAP]"":DDGFCAP,1:"@")_";"
 .. S:DDGFSUP'=DDGFSUP0 DR=DR_"5.2////"_$S(DDGFSUP:1,1:"@")_";"
 . ;
 . D:DDGFCC'=DDGFCC0
 .. S C1=$S(DDGFCAP]"":$P(DDGFCC,",")-1+$P(DDGFNDB,U),1:"")
 .. S C2=$S(DDGFCAP]"":$P(DDGFCC,",",2)-1+$P(DDGFNDB,U,2),1:"")
 .. S DR=DR_"5.1////"_$S(DDGFCC]"":DDGFCC,1:"@")_";"
 . ;
 . D:$D(D)
 .. D:DDGFDC'=DDGFDC0
 ... S D1=$P(DDGFDC,",")-1+$P(DDGFNDB,U)
 ... S D2=$P(DDGFDC,",",2)-1+$P(DDGFNDB,U,2)
 ... S DR=DR_"4.1////"_DDGFDC_";"
 .. D:DDGFDL'=DDGFDL0
 ... S L=DDGFDL
 ... S D=$TR($J("",L)," ","_")
 ... S DR=DR_"4.2////"_DDGFDL_";"
 . ;
 . I T="D",C]"" D
 .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",1)
 .. S @DDGFREF@("RC",DDGFWID,C1,C2,C2+$L(C)-1,B,F,"C")=""
 . ;
 . I DR]"" D
 .. N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2
 .. S DIE="^DIST(.404,"_DA(1)_",40,"
 .. S DR=$E(DR,1,$L(DR)-1)
 .. D ^DIE
 ;
 K DA,DDGFNDB
 K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0
 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0,DDSSAVE
 K DIE,DR
 ;
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
EDITQ S DDGFE=1
 K DDGFDY,DDGFDX,DDGFTYPE
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFFLDA
DDGFFLDA ;SFISC/MKO-ADD A FIELD ;08:59 AM  14 Feb 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ADD ;Add a field
 I '$O(^DIST(.403,+DDGFFM,40,DDGFPG,40,0)) D  Q
 . D MSG^DDGF($C(7)_"There are no blocks defined on this page.  To add a block, press <PF2>B.")
 . H 2 D MSG^DDGF()
 S DDGFDY=DY,DDGFDX=DX
 ;
 ;Invoke form to select block, field order, field type
 K DDGFBLCK,DDGFFORD,DDGFTYPE
 S DDSFILE=.404,DDSFILE(1)=.4044
 S DR="[DDGF FIELD ADD]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DA,DR,DDSPARM
 ;
 I '$D(DDGFBLCK)!'$D(DDGFFORD)!'$D(DDGFTYPE) G ADDQ
 ;
 ;Get relative field coordinates
 S (DDGFCAP,DDGFCAP0)=""
 S (DDGFSUP,DDGFSUP0)=""
 S (DDGFCC,DDGFCC0)=""
 ;
 S DDGFB2=@DDGFREF@("F",DDGFPG,DDGFBLCK)
 S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2)
 ;
 I DDGFTYPE=1 D
 . S DDGFCC0=DDGFDY-DDGFB1+1_","_(DDGFDX-DDGFB2+1)
 E  D
 . S DDGFD1=DDGFDY-DDGFB1+1,DDGFD2=DDGFDX-DDGFB2+1
 . S (DDGFDC,DDGFDC0)=DDGFD1_","_DDGFD2
 . S (DDGFDL,DDGFDL0)=1
 ;
 I DDGFTYPE'=1,DDGFD1<1!(DDGFD2<1) D  G ADDQ
 . D MSG^DDGF($C(7)_"Unable to add a field above or to the left of the block.")
 . H 2 D MSG^DDGF()
 ;
 K DDGFD1,DDGFD2
 ;
 ;Add field order to block file
 S DIC="^DIST(.404,"_DDGFBLCK_",40,",DIC(0)="L"
 S DIC("P")=$P(^DD(.404,40,0),U,2)
 S DA(1)=DDGFBLCK,X=DDGFFORD
 D FILE^DICN
 I Y=-1 K DIC,DA,Y D MSG^DDGF($C(7)_"Unable to add field.") H 2 D MSG^DDGF() G ADDQ
 ;
 ;Stuff values for field type, data coordinate, and data length
 ;If form-only field, also stuff in default read type
 S DIE=DIC,DA(1)=DDGFBLCK,DA=+Y
 S DR="2////"_DDGFTYPE
 S:DDGFTYPE'=1 DR=DR_";4.1////"_DDGFDC_";4.2////1"
 S:DDGFTYPE=2 DR=DR_";20.1////F"
 D ^DIE K DIC,DIE,DR,Y
 ;
 ;Invoke appropriate form
 S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="CKTW"
 S DDGFDD=$P(^DIST(.404,DDGFBLCK,0),U,2)
 S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]"
 D ^DDS K DDSFILE,DR,DDSPARM,DDGFDD
 ;
 I $D(DA)#2,DDGFTYPE'=1,$G(DDSCHANG)'=1 D
 . S DIK="^DIST(.404,"_DA(1)_",40,"
 . D ^DIK K DIK
 E  I $D(DA)#2 D
 . D SAVE
 . D LOADF
 ;
ADDQ ;Refresh and cleanup
 D REFRESH^DDGF
 D RC(DDGFDY,DDGFDX)
 ;
 K DA,DDSCHANG
 K DDGFB1,DDGFB2,DDGFD1,DDGFD2
 K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0
 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0
 K DDGFDY,DDGFDX,DDGFBLCK,DDGFFORD,DDGFTYPE
 Q
 ;
SAVE ;Save changes to caption, coordinates, data length, and suppress
 ;colon flag
 S:DDGFCAP="" (DDGFSUP,DDGFCC)=""
 S DR=""
 ;
 S:DDGFCAP]"" DR=DR_"1////"_DDGFCAP_";"
 S:DDGFCC]"" DR=DR_"5.1////"_DDGFCC_";"
 S:DDGFSUP DR=DR_"5.2////1;"
 ;
 I DDGFTYPE'=1 D
 . S:DDGFDC'=DDGFDC0 DR=DR_"4.1////"_DDGFDC_";"
 . S:DDGFDL'=DDGFDL0 DR=DR_"4.2////"_DDGFDL_";"
 I DR="" K DR Q
 ;
 S DIE="^DIST(.404,"_DA(1)_",40,"
 S DR=$E(DR,1,$L(DR)-1)
 D ^DIE K DIE,DR,Y
 Q
 ;
LOADF ;Set DDGFREF and window buffer
 N C,C1,C2,C3,D,D1,D2,D3,L
 ;
 I DDGFCAP="" D
 . S (C,C1,C2,C3)=""
 . K @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)
 E  D
 . S C=DDGFCAP_$S(DDGFTYPE'=1&'DDGFSUP:":",1:"")
 . S C1=$P(DDGFCC,",")-1+DDGFB1
 . S C2=$P(DDGFCC,",",2)-1+DDGFB2
 . S C3=C2+$L(C)-1
 . ;
 . S @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)=C1_U_C2_U_C3_U_C
 . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,DDGFBLCK,DA,"C")=""
 . D WRITE^DDGLIBW(DDGFWID,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
 ;
 I DDGFTYPE'=1 D
 . S D1=$P(DDGFDC,",")-1+DDGFB1
 . S D2=$P(DDGFDC,",",2)-1+DDGFB2
 . S D3=D2+DDGFDL-1
 . ;
 . S $P(@DDGFREF@("F",DDGFPG,DDGFBLCK,DA),U,5,8)=D1_U_D2_U_D3_U_DDGFDL
 . I D1]"",D2]"" S @DDGFREF@("RC",DDGFWID,D1,D2,D3,DDGFBLCK,DA,"D")=""
 . D:DDGFDL WRITE^DDGLIBW(DDGFWID,$TR($J("",DDGFDL)," ","_"),D1-$P(DDGFLIM,U),D2-$P(DDGFLIM,U,2),"",1)
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFFM
DDGFFM ;SFISC/MKO-FORM ADD, EDIT, SELECT ;11:48 AM  20 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
SEL ;Select another form
ADD ;Add a new form
 N X,DIR0 K DDGFABT
 S DDGFDY=+$G(DY),DDGFDX=+$G(DX),(DY,DX)=0 X IOXY
 W $P(DDGLCLR,DDGLDEL,2)
 X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
 ;
 ;Select file
FIL S DDS1="EDIT/CREATE FORM FOR" D W^DICRW K DDS1 G:Y<0 ADDQ
 G:'$D(@(DIC_"0)")) ADDQ
 ;
 ;Select form
 W !
 S DIC("S")="I $P(^(0),U,8)=+DDGFFILE"
 I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,3)) I DUZ(0)[$E($P(^(0),U,3),DDSI) Q"
 S DDGFFILE=Y,DIC=.403,DIC(0)="QEAL",D="F"_+Y
 D IX^DIC K DIC,D G:Y<0 ADDQ
 S DDGFY=Y
 ;
 ;Save data for previous form
 I DDGFCHG,$D(DDGFFM)#2 G:+DDGFFM=+DDGFY ADDQ D  G:$G(DDGFABT) ADDQ
 . N DDGFFNAM
 . S DIR(0)="Y",DDGFFNAM=$P(DDGFFM,U,2)
 . S DIR("A")="Save changes to form "_DDGFFNAM
 . S DIR("B")="YES"
 . S DIR("?",1)="  Enter 'Y' or press 'Return' to save changes."
 . S DIR("?",2)="  Enter 'N' to discard changes."
 . S DIR("?")="  Enter '^' to return to form "_DDGFFNAM
 . W ! D ^DIR K DIR I $D(DIRUT) K DIRUT,DUOUT,DTOUT S DDGFABT=1 Q
 . D SAVE^DDGFSV
 ;
 I $D(DDGFFM)#2,+DDGFFM'=+DDGFY D RECOMP^DDGF0
 ;
 S DDGFFM=$P(DDGFY,U,1,2)
 ;
 ;Stuff in values for form
 K DR S DIE=.403,DA=+DDGFY,DDGFNEW=$P(DDGFY,U,3)
 S:DDGFNEW DR="3////"_DUZ_";4///NOW"
 S DR=$S($G(DR)]"":DR_";",1:"")_"5///NOW"
 S:DDGFNEW DR=DR_";7////"_+DDGFFILE
 D ^DIE K DIE,DA,DR,D,%DT
 I DDGFNEW,$G(DUZ(0))]"" D
 . S $P(^DIST(.403,+DDGFFM,0),U,2,3)=DUZ(0)_U_DUZ(0)
 ;
 ;If this is a new form, create Page 1
 I DDGFNEW D
 . K DD,DO
 . S DIC="^DIST(.403,+DDGFFM,40,",DIC("P")=$P(^DD(.403,40,0),U,2)
 . S DIC(0)="",DA(1)=+DDGFFM,X=1
 . D FILE^DICN I Y=-1 K DIC,Y Q
 . S DIE=DIC,DA=+Y,DR="2////1,1;7////Page 1"
 . D ^DIE K DIC,DIE,DA,DR,D,Y
 ;
 ;Clear data for previous form
 W $P(DDGLCLR,DDGLDEL,2)
 I $D(@DDGFREF) K @DDGFREF D DESTALL^DDGLIBW
 ;
 ;Get first page, load form
 S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",""))
 I DDGFPG]"" S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,""))
 D PG^DDGFLOAD(+DDGFFM,DDGFPG),STATUS^DDGF
 S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2)
 ;
ADDQQ X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 D RC(DDGFDY,DDGFDX)
 K DDGFABT,DDGFDY,DDGFDX,DDGFNEW,DDGFY
 Q
 ;
ADDQ I $D(DDGFFM)#2 D REFRESH^DDGF G ADDQQ
 K DDGFABT,DDGFDY,DDGFDX
 Q
 ;
EDIT ;Invoke form to edit form
 S DDGFDY=DY,DDGFDX=DX
 K DDSFILE S DDSFILE=.403
 S DA=+DDGFFM,DR="[DDGF FORM EDIT]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DR,DDSPARM
 ;
 S $P(DDGFFM,U,2)=$P(^DIST(.403,+DDGFFM,0),U)
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
EDITQ K DDGFDY,DDGFDX
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N DDGFS
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W DDGFS_$J("",7-$L(DDGFS))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFH
DDGFH ;SFISC/MKO-HELP SCREENS ;09:20 AM  7 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
HLP ;Print help screens, refresh screen
 D HLP^DDGLIBH(9251,9259,"DDGFH")
 D REFRESH^DDGF,RC(DY,DX)
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N DDGFS
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W DDGFS_$J("",7-$L(DDGFS))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFHBK
DDGFHBK ;SFISC/MKO-ADD, EDIT, DELETE HEADER BLOCK ;01:48 PM  22 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ADD ;Add a header block
 ;Check to see if a header block already exists for this page
 S DDGFBH=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
 I DDGFBH D MSG^DDGF($C(7)_"This page already has a header block.") H 2 D MSG^DDGF() K DDGFBH Q
 ;
 N B
 S DDGFDY=DY,DDGFDX=DX
 ;
 ;Invoke form to enter block name
 K DDGFBNUM,DDGFBNAM
 D DDS(.404,"[DDGF HEADER BLOCK SELECT]")
 G:$G(DDGFBNUM)=DDGFBH!'$G(DDGFBNUM) ADDQ
 ;
 I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,"B",DDGFBNUM)) D DDS(.404,"[DDGF BLOCK ADD]","",21) G ADDQ
 ;
 S $P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM
 ;
 ;If this looks like a brand new block, stuff in DD number
 I $L(^DIST(.404,DDGFBNUM,0),U)=1,'$O(^(0)) D
 . S DIE="^DIST(.404,",DA=DDGFBNUM
 . S DR="1////"_$P(^DIST(.403,+DDGFFM,0),U,8)
 . D ^DIE K DIE,DA,DR
 ;
 D:DDGFBH DELETE^DDGFBK(DDGFBH,1)
 D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)
 ;
 S DY=DDGFDY,DX=DDGFDX
 S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
 S DDGFADD=1
 K DDGFBNUM,DDGFBNAM
 G EDIT
 ;
ADDQ ;Abort adding a header block
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 K DDGFANS,DDGFBH,DDGFBNUM,DDGFBNAM,DDGFDY,DDGFDX
 Q
 ;
EDIT ;Edit/Delete header block
 ;In: B,C
 N C1,C2,C3
 S DDGFDY=DY,DDGFDX=DX,DDGFBH=B
 S (DDGFBKNN,DDGFBKNO)=C
 S DDSFILE=.403,DDSFILE(1)=.4031,DA(1)=+DDGFFM,DA=DDGFPG
 S DR="[DDGF HEADER BLOCK EDIT]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DA,DR,DDSPARM
 S DDGFBHN=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
 ;
 I DDGFBHN'=DDGFBH D
 . D DELETE^DDGFBK(DDGFBH,DDGFBHN)
 . D:DDGFBHN BK^DDGFLOAD(DDGFPG,DDGFBHN,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)
 ;
 S C=DDGFBKNN,B=DDGFBHN
 ;
 ;Update TMP if coordinates or name changed, or new block
 I DDGFBKNN'=DDGFBKNO!$G(DDGFADD) D
 . D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)
 . D WRITE^DDGLIBW(DDGFWIDB,C,$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)
 ;
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 S:'$G(DDGFADD) DDGFE=1
 K DDGFADD,DDGFBH,DDGFBHN,DDGFBKNN,DDGFBKNO,DDGFDY,DDGFDX
 Q
 ;
DDS(DDSFILE,DR,DA,DDSPAGE) ;
 ;Call DDS
 S DDSPARM="KTW" D ^DDS K DDSPARM
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFLOAD
DDGFLOAD ;SFISC/MKO-LOAD PAGE/BLOCK ;12:33 PM  29 Mar 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PG(S,P,V,R) ;
 ;Load and paint page
 ;Called when a new form or page is selected
 ;If Page is not pop-up close all windows first
 ;Input:
 ; S = internal form number
 ; P = internal page number
 ; V = 1 if buffer should be updated but nothing painted
 ;     (new windows are still given focus)
 ; R = 1 to reload blocks/fields on page even if loaded before
 ;Returns:
 ; DDGFWID  = Window number for a given page
 ; DDGFWIDB = Window number of block displayer for a given page
 ; DDGFLIM  = Boundaries within which cursor can be moved
 ;
 I $D(^DIST(.403,+$G(S),40,+$G(P),0))[0 S DDGFWID="P0",DDGFWIDB="B0",DDGFLIM="0^0^"_(IOSL-8)_U_(IOM-2),DDGFPG=0 Q
 ;
 S DDGFWID="P"_DDGFPG,DDGFWIDB="B"_DDGFPG
 I $$EXIST^DDGLIBW(DDGFWID),$G(R) D DESTROY^DDGLIBW(DDGFWID,1)
 I $$EXIST^DDGLIBW(DDGFWID),'$G(R) D  Q
 . S DDGFLIM=$P(@DDGFREF@("F",P),U,1,4)
 . I $P(DDGFLIM,U,3,4)?."^" D
 .. S $P(DDGFLIM,U,3,4)=IOSL-8_U_(IOM-2)
 .. D CLOSEALL^DDGLIBW($G(V))
 . D FOCUS^DDGLIBW(DDGFWID,$G(V))
 ;
 N P1,P2,P3,P4,B,B1,B2
 ;
 ;Get page coordinates
 I $D(@DDGFREF@("F",+P))#2 D
 . N N
 . S N=@DDGFREF@("F",+P)
 . S P1=$P(N,U),P2=$P(N,U,2),P3=$P(N,U,3),P4=$P(N,U,4)
 E  D
 . S P2=$P(^DIST(.403,+S,40,+P,0),U,3),P3=$P(^(0),U,7)
 . S P1=$P(P2,",")-1,P2=$P(P2,",",2)-1
 . S:P1<0 P1=0 S:P2<0 P2=0
 . S:P3]"" P4=$P(P3,",",2)-1,P3=$P(P3,",")-1
 . S @DDGFREF@("F",P)=P1_U_P2_U_$S(P3]"":P3_U_P4,1:U)_U_$P($G(^DIST(.403,+S,40,+P,1)),U)_U_$P(^(0),U)
 ;
 I P3]"" D
 . S DDGFLIM=P1_U_P2_U_P3_U_P4
 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1,$G(V))
 . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
 . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
 ;
 E  D
 . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2)
 . D CLOSEALL^DDGLIBW($G(V))
 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2),"",$G(V))
 ;
 ;Load header block
 S B=$P(^DIST(.403,+S,40,+P,0),U,2) I B]"" D
 . S B1=P1,B2=P2
 . D BK(+P,B,P1,P2,B1,B2,1,$G(V))
 ;
 ;Load all other blocks
 S B=0 F  S B=$O(^DIST(.403,+S,40,+P,40,B)) Q:B'=+$P(B,"E")  D
 . Q:$D(^DIST(.403,+S,40,+P,40,B,0))[0
 . S B2=$P(^DIST(.403,+S,40,+P,40,B,0),U,3)
 . S B1=$P(B2,",")-1,B2=$P(B2,",",2)-1
 . S:B1<0 B1=0 S:B2<0 B2=0
 . S B1=B1+P1,B2=B2+P2
 . D BK(+P,B,P1,P2,B1,B2,"",$G(V))
 Q
 ;
BK(P,B,P1,P2,B1,B2,H,V) ;Load block image
 ; P  = internal page number
 ; B  = internal block number
 ; P1 = page $Y
 ; P2 = page $X
 ; B1 = block abs $Y
 ; B2 = block abs $X
 ; H  = 1 if header block, immobile (optional)
 ; V  = 1 if buffer should be updated but nothing painted (optional)
 N B3,F,F1,C,C1,C2,C3,D1,D2,D3,I,L,N,T
 Q:$D(^DIST(.404,B,0))[0
 ;
 S N=$P(^DIST(.404,B,0),U)
 S:$G(H) B1=P1,B2=P2
 S B3=B2+$L(N)-1
 S @DDGFREF@("F",P,B)=B1_U_B2_U_B3_U_N
 S @DDGFREF@("BKRC",DDGFWIDB,B1,B2,B3,B)=$S($G(H):"H",1:"")
 ;
 S F1=""
 F  S F1=$O(^DIST(.404,B,40,"B",F1)) Q:F1=""  S F=$O(^(F1,"")) D:F
 . Q:$D(^DIST(.404,B,40,F,0))[0
 . S C=$P(^DIST(.404,B,40,F,0),U,2),C2=$P($G(^(2)),U,3)
 . I C]"",'$P($G(^DIST(.404,B,40,F,2)),U,4),$P(^(0),U,3)'=1 S C=C_":"
 . S L=$P($G(^DIST(.404,B,40,F,2)),U,2),D2=$P($G(^(2)),U)
 . S T=$P(^DIST(.404,B,40,F,0),U,3)
 . ;
 . ;Kill nodes that are null or contain only ^s
 . S I=0
 . F  S I=$O(^DIST(.404,B,40,F,I)) Q:'I  I $D(^(I))=1,^(I)?."^" K ^(I)
 . ;
 . ;Check that fields with captions have caption coords
 . I C]"",'C2 S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
 . ;
 . ;Check for DD fields that should be Caption fields
 . I T=3,$D(^DIST(.404,B,40,F,1))[0,'$O(^(2)) D
 .. S T=1,(D2,L)=""
 .. S C=$P($G(^DIST(.404,B,40,F,0)),U,2)
 .. S $P(^DIST(.404,B,40,F,0),U,3)=1
 .. S $P(^DIST(.404,B,40,F,2),U,1,4)="^^"_C2_"^"
 . ;
 . ;Check that fields have some coordinate
 . I 'C2,T=1!'D2 D
 .. I C="" D
 ... S C="** Null **",$P(^DIST(.404,B,40,F,0),U,2)=C,$P(^(2),U,4)=""
 ... S:T'=1 C=C_":"
 .. S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
 . ;
 . ;Make sure nonCaption fields have data coordinates and length
 . I T'=1 D
 .. S:'D2 D2=+C2_","_($P(C2,",",2)+$L(C)+1),$P(^DIST(.404,B,40,F,2),U)=D2
 .. S:'L L=1,$P(^DIST(.404,B,40,F,2),U,2)=1
 .. I C="",C2 S C2="",$P(^DIST(.404,B,40,F,2),U,3)=""
 . ;
 . I C]"" D
 .. S C1=$P(C2,",")-1+B1,C2=$P(C2,",",2)-1+B2,C3=C2+$L(C)-1
 .. S @DDGFREF@("F",P,B,F)=C1_U_C2_U_C3_U_C
 .. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
 .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",$G(V))
 . ;
 . ;NonCaption fields
 . I T'=1 D
 .. S D1=$P(D2,",")-1+B1,D2=$P(D2,",",2)-1+B2,D3=D2+L-1
 .. S $P(@DDGFREF@("F",P,B,F),U,5,8)=D1_U_D2_U_D3_U_L
 .. S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
 .. D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),D1-P1,D2-P2,"",$G(V))
 Q

DDGFORD
DDGFORD ;SFISC/MKO-REORDER THE FIELDS ON BLOCK ;07:13 AM  25 May 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;In: DDGFBK   = Block number
 ;    DDGFPG   = Page number
 ;    DDGFFM   = Form number^Form name
 ;    DDGFREF  = Global reference
 ;
EN(DDGFBK) ;
 N DDO,DA,DIK
 N DDGFLN,DDGFLIST,DDGFR,DDGFC,DDGFN,DDGFO
 ;
 D MSG^DDGF("Reordering ...")
 ;Loop through all fields in DDGFREF and put into DDGFLIST array
 S DDO="" F  S DDO=$O(@DDGFREF@("F",DDGFPG,DDGFBK,DDO)) Q:DDO=""  D
 . S DDGFLN=@DDGFREF@("F",DDGFPG,DDGFBK,DDO)
 . I $P(DDGFLN,U,8)>0 S DDGFLIST(+$P(DDGFLN,U,5),+$P(DDGFLN,U,6),DDO)=""
 . E  I $P(DDGFLN,U,4)]"" S DDGFLIST(+$P(DDGFLN,U),+$P(DDGFLN,U,2),DDO)=""
 ;
 K ^DIST(.404,DDGFBK,40,"B")
 S DDGFN=0
 S DDGFR="" F  S DDGFR=$O(DDGFLIST(DDGFR)) Q:DDGFR=""  D
 . S DDGFC="" F  S DDGFC=$O(DDGFLIST(DDGFR,DDGFC)) Q:DDGFC=""  D
 .. S DDO="" F  S DDO=$O(DDGFLIST(DDGFR,DDGFC,DDO)) Q:DDO=""  D
 ... S DDGFN=DDGFN+1
 ... S DDGFO=$P(^DIST(.404,DDGFBK,40,DDO,0),U)
 ... S:DDGFO'=DDGFN $P(^DIST(.404,DDGFBK,40,DDO,0),U)=DDGFN
 ;
 S DIK="^DIST(.404,DDGFBK,40,",DA(1)=DDGFBK,DIK(1)=".01^B"
 D ENALL^DIK
 D MSG^DDGF("Reordering completed.") H 1
 D MSG^DDGF()
 Q

DDGFPG
DDGFPG ;SFISC/MKO-ADD A NEW PAGE ;01:48 PM  22 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ADD ;Invoke forms to add a new page
 S DDGFDY=DY,DDGFDX=DX K DDGFPNUM
 ;
 ;Ask for new page number
 S DDSFILE=.403,DDSFILE(1)=.4031
 S DA(1)=+DDGFFM,DA="",DR="[DDGF PAGE ADD]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DA,DR,DDSPARM
 ;
 G:$D(DDGFPNUM)[0 ADDQ
 ;
 ;Ask 'are you sure' page should be added
 K DDGFANS
 S DDSFILE=.403,DDSFILE(1)=.4031
 S DR="[DDGF PAGE ADD]",DA(1)=+DDGFFM,DA="",DDSPARM="KTW",DDSPAGE=11
 D ^DDS K DDSFILE,DA,DR,DDSPARM,DDSPAGE
 ;
 I '$G(DDGFANS) K DDGFANS G ADDQ
 K DDGFANS
 ;
 ;Add page to form
 S DIC="^DIST(.403,+DDGFFM,40,",DIC(0)="L",DA(1)=+DDGFFM
 S DIC("P")=$P(^DD(.403,40,0),U,2),X=DDGFPNUM
 D FILE^DICN K DIC,DA,X G:Y=-1 ADDQ
 S DDGFPG=+Y
 ;
 ;Stuff in values for coordinates and name
 S DIE="^DIST(.403,"_+DDGFFM_",40,",DA(1)=+DDGFFM,DA=DDGFPG
 S DR="2////1,1;7////Page "_DDGFPNUM
 D ^DIE K DIE,DA,DR
 ;
 K DDGFPNUM
 D LOADPG
 S DDGFNEW=1
 G EDIT
 ;
ADDQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 K DDGFPNUM,DDGFDY,DDGFDX
 Q
 ;
EDIT ;Invoke form to edit a page
 ;Input:  DDGFNEW (optional)
 ;  Set by ADD to indicate this is a brand new page.
 ;
 S DDGFDY=DY,DDGFDX=DX
 S DDGFND=@DDGFREF@("F",DDGFPG)
 S (DDGFTLC,DDGFTLC0)=$P(DDGFND,U)+1_","_($P(DDGFND,U,2)+1)
 S (DDGFLRC,DDGFLRC0)=$S($P(DDGFND,U,3)]"":$P(DDGFND,U,3)+1_","_($P(DDGFND,U,4)+1),1:"")
 S (DDGFPNM,DDGFPNM0)=$P(DDGFND,U,5)
 S DDGFPAR=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2)
 ;
 S DDSFILE=.403,DDSFILE(1)=.4031,DDSPARM="KTW"
 S DA(1)=+DDGFFM,DA=DDGFPG,DR="[DDGF PAGE EDIT]"
 D ^DDS K DDSFILE,DA,DR,DDSPARM
 ;
 S DDGFND=$G(^DIST(.403,+DDGFFM,40,DDGFPG,0))
 ;
 ;If page was deleted, destroy windows and set new page
 I DDGFND="" D  Q:DDGFE
 . I $D(DDGFWID)#2,$$EXIST^DDGLIBW(DDGFWID) D DESTROY^DDGLIBW(DDGFWID)
 . I $D(DDGFWIDB)#2,$$EXIST^DDGLIBW(DDGFWIDB) D DESTROY^DDGLIBW(DDGFWIDB)
 . K @DDGFREF@("F",DDGFPG),@DDGFREF@("RC",DDGFWID),@DDGFREF@("BKRC",DDGFWIDB)
 . I $D(@DDGFREF@("ASUB","B",DDGFPG)) D DEL^DDGFASUB(DDGFPG)
 . S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",""))
 . S:DDGFPG]"" DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,""))
 . D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 ;
 E  D
 . S:DDGFPNM'=DDGFPNM0 $P(@DDGFREF@("F",DDGFPG),U,5)=DDGFPNM,$P(^(DDGFPG),U,7)=1,DDGFCHG=1
 . D:DDGFPAR'=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) EDIT^DDGFASUB(DDGFPG)
 . I DDGFTLC'=DDGFTLC0!(DDGFLRC'=DDGFLRC0) D
 .. D PAGE^DDGFUPDP($P(DDGFTLC,",")-1,$P(DDGFTLC,",",2)-1,$S(DDGFLRC]"":$P(DDGFLRC,",")-1,1:""),$S(DDGFLRC]"":$P(DDGFLRC,",",2)-1,1:""),$S(DDGFTLC=DDGFTLC0:"PBRC",1:"PTOP"))
 .. D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
 . E  D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 ;
 K DDGFDX,DDGFDY,DDGFND,DDGFNEW
 K DDGFLRC,DDGFLRC0,DDGFPOP,DDGFPOP0,DDGFTLC,DDGFTLC0
 K DDGFPAR,DDGFPNM,DDGFPNM0
 Q
 ;
PGSEL ;Select a new page
 S DDGFDY=DY,DDGFDX=DX,DDGFPAGE=DDGFPG
 ;
 S DDSFILE=.403,DDSFILE(1)=.4031
 S DR="[DDGF PAGE SELECT]",DDSPARM="KTW"
 D ^DDS
 K DDSFILE,DA,DR,DDSPAGE,DDSPARM
 ;
 I DDGFPAGE]"",DDGFPAGE'=DDGFPG S DDGFPG=DDGFPAGE D LOADPG
 ;
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
 K DDGFPAGE,DDGFDY,DDGFDX
 Q
 ;
NXTPRV(F) ;Go to page
 ;F=1:next page; -1:previous page
 S DDGFPAGE=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,0)),U,$S($G(F)=-1:5,1:4))
 G:DDGFPAGE="" NXTPRVQ
 S DDGFPAGE=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPAGE,""))
 G:$D(^DIST(.403,+DDGFFM,40,+DDGFPAGE,0))[0!(DDGFPAGE=DDGFPG) NXTPRVQ
 ;
 S DDGFPG=DDGFPAGE
 D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX)
NXTPRVQ K DDGFPAGE,DDGFDY,DDGFDX
 Q
 ;
CLSPG ;Close page
 Q:$G(DDGLSCR)'>1
 D CLOSE^DDGLIBW(DDGFWID)
 S DDGFPG=$E(DDGLSCR(DDGLSCR),2,999)
 D PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
 D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
 Q
 ;
SUBPG ;Go into subpage
 I $D(@DDGFREF@("ASUB",DDGFPG,B,F))#2 S DDGFSUBP=^(F)
 E  D
 . S DDGFSUBP=+$P($G(^DIST(.404,B,40,F,7)),U,2)
 . S DDGFSUBP=+$O(^DIST(.403,+DDGFFM,40,"B",DDGFSUBP,""))
 ;
 I $D(^DIST(.403,+DDGFFM,40,DDGFSUBP,0))[0 W $C(7) K DDGFSUBP Q
 I DDGFSUBP=DDGFPG K DDGFSUBP Q
 S DDGFE=1
 Q
 ;
SUBPG1 S DDGFPG=DDGFSUBP K DDGFSUBP
 D PG^DDGFLOAD(+DDGFFM,DDGFPG)
 D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
 Q
 ;
LOADPG ;Load new page
 D PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
 S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2)
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N S
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W S_$J("",7-$L(S))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q

DDGFSV
DDGFSV ;SFISC/MKO- SAVE DATA ;12:41 PM  29 Mar 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SAVE ;Save in form/block files data in DDGFREF
 N P,B,F,P1,B1,F1,N
 ;
 I '$G(DDGFCHG) D MSG^DDGF("Nothing to save.") H 1 D MSG^DDGF() Q
 D MSG^DDGF("Saving data ...")
 ;
 ;Loop through all pages in DDGFREF
 S P="" F  S P=$O(@DDGFREF@("F",P)) Q:P=""  D PG
 ;
 D MSG^DDGF("Data saved.") H 1 D MSG^DDGF()
 S DDGFCHG=0
 Q
 ;
PG ;Save page data
 S P1=@DDGFREF@("F",P)
 I $P(P1,U,7),$D(^DIST(.403,+DDGFFM,40,P,0))#2 D
 . S N=^DIST(.403,+DDGFFM,40,P,0)
 . S $P(N,U,3)=$P(P1,U)+1_","_($P(P1,U,2)+1)
 . S $P(N,U,6,7)=$S($P(P1,U,3)="":U,1:1_U_($P(P1,U,3)+1)_","_($P(P1,U,4)+1))
 . S ^DIST(.403,+DDGFFM,40,P,0)=$$STPU(N)
 . ;
 . S N=$G(^DIST(.403,+DDGFFM,40,P,1))
 . I $P(N,U)'=$P(P1,U,5) D
 .. S DIE="^DIST(.403,"_+DDGFFM_",40,"
 .. S DR="7////"_$P(P1,U,5),DA(1)=+DDGFFM,DA=P
 .. N P D ^DIE K DIE,DR,DA
 ;
 ;Loop through all blocks
 S B="" F  S B=$O(@DDGFREF@("F",P,B)) Q:B=""  D BK
 Q
 ;
BK ;Save block data
 S B1=@DDGFREF@("F",P,B)
 I $P(B1,U,5),$D(^DIST(.403,+DDGFFM,40,P,40,B,0))#2 D
 . S $P(^DIST(.403,+DDGFFM,40,P,40,B,0),U,3)=$P(B1,U)-$P(P1,U)+1_","_($P(B1,U,2)-$P(P1,U,2)+1)
 . I $P(^DIST(.404,B,0),U)'=$P(B1,U,4) D
 .. S DIE="^DIST(.404,",DR=".01////"_$P(B1,U,4),DA=B
 .. N B,P D ^DIE K DIE,DR,DA
 ;
 ;Loop through all fields
 S F="" F  S F=$O(@DDGFREF@("F",P,B,F)) Q:F=""  D FD
 Q
 ;
FD ;Save field data
 S F1=@DDGFREF@("F",P,B,F)
 I $P(F1,U,9),$D(^DIST(.404,B,40,F,0))#2 D
 . S N=""
 . S $P(N,U,1,2)=$S($P(F1,U,8):$S($P(F1,U,5)]""&($P(F1,U,6)]""):$P(F1,U,5)-$P(B1,U)+1_","_($P(F1,U,6)-$P(B1,U,2)+1),1:"")_U_$P(F1,U,8),1:U)
 . S $P(N,U,3,4)=$S($L($P(F1,U,4)):$S($P(F1,U)]""&($P(F1,U,2)]""):$P(F1,U)-$P(B1,U)+1_","_($P(F1,U,2)-$P(B1,U,2)+1),1:"")_U_$S($P(F1,U,4)?.E1":":"",1:1),1:U)
 . S:$P(^DIST(.404,B,40,F,0),U,3)=1 $P(N,U,4)=""
 . S ^DIST(.404,B,40,F,2)=$$STPU(N)
 . ;
 . ;Use DIE to stuff in new caption
 . I $P(^DIST(.404,B,40,F,0),U,2)'=$P(F1,U,4) D
 .. S DIE="^DIST(.404,"_B_",40,"
 .. S DR="1////"_$S($P(F1,U,4)?.1":":"@",$P(F1,U,4)?1.E1":":$E($P(F1,U,4),1,$L($P(F1,U,4))-1),1:$P(F1,U,4))
 .. S DA(1)=B,DA=F
 .. N P,B,F D ^DIE K DIE,DR,DA
 Q
 ;
STPU(X) ;Strip trailing up-arrows from X
 N I
 F I=$L(X):-1:0 Q:$E(X,I)'="^"
 Q $E(X,1,I)

DDGFU
DDGFU ;SFISC/MKO-CALLED FROM THE FORMS ;10:49 AM  27 Jul 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
VAL1 ;Data validation code
 ;Form: DDS FIELD ADD
 I $$GET^DDSVALF("BLOCK","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD ORDER","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD TYPE","DDGF FIELD ADD")]"" Q
 ;
 S DDGFT(1)=$C(7)_"Unable to save values."
 S DDGFT(2)="All values must be filled in order to add a new field."
 D HLP^DDSUTL(.DDGFT)
 S DDSERROR=1
 K DDGFT
 Q
 ;
DDCAP ;Caption, Post action on change
 ;Form:  DDGF FIELD DD
 N DDGFOPG
 S DDGFOPG=$$OTHPG
 D:DDSOLD="!M" PUT^DDSVAL(.4044,.DA,1.1,"")
 ;
 D:X="" CAPNULL(DDGFOPG)
 D:X]"" UPDDC(DDGFOPG)
 Q
 ;
OTHPG() ;Return Other Params page#
 N FLD,SUB,OPG
 S FLD=$$GET^DDSVAL(.4044,.DA,4)
 I FLD D
 . S OPG=11
 . S SUB=+$P($G(^DD(DDGFDD,FLD,0)),U,2)
 . S:SUB OPG=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31)
 Q $G(OPG)
 ;
FOCAP ;Caption, Post action on change
 ;Form:  DDGF FIELD FORM ONLY
 D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"")
 ;
 D:X="" CAPNULL(21)
 D:X]"" UPDDC(21)
 Q
 ;
COMPCAP ;Caption, Post action on change
 ;Form:  DDGF FIELD COMPUTED
 D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"")
 ;
 D:X="" CAPNULL(11)
 D:X]"" UPDDC(11)
 Q
 ;
CAPNULL(OPG) ;Caption changed to null
 N DC,SC
 ;
 ;Clear suppress colon
 S SC=$$GET^DDSVALF("SUPPRESS COLON AFTER CAPTION?")
 D PUT^DDSVALF("SUPPRESS COLON AFTER CAPTION?","","","","I")
 Q:'$G(OPG)
 ;
 ;Clear caption coords
 D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,"")
 ;
 ;Move data to the left
 S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG)
 S $P(DC,",",2)=$P(DC,",",2)-$L(DDSOLD)-1-'SC
 S:$P(DC,",",2)<1 $P(DC,",",2)=1
 D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC,"I")
 Q
 ;
UPDDC(OPG) ;Update data coords
 N DC,COL
 S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG)
 S COL=$P(DC,",",2),COL=COL+$L(X)-$L(DDSOLD)
 I DDSOLD="" D
 . D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,DC,"I")
 . S COL=COL+2
 S:COL<1 COL=1
 S $P(DC,",",2)=COL
 D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC)
 Q
 ;
POSTCH1 ;Field, Post Action On Change
 ;Form: DDGF FIELD DD
 ;
 ;Reset (if caption not !M): caption, caption and data coords,
 ; data length
 ;Input:
 ; DDGFPG = Page #
 ; DA(1)  = Block #
 ; DA     = Field order
 ; X      = Fld #
 ; DDSOLD = Prev fld #
 ;
 Q:X=""
 N FILE,FLD,DD,C,C0,CC,DC,SC,L,OPG,OPG0,PLRC
 ;
 S FLD=X
 S FILE=+$P(^DIST(.404,DA(1),0),U,2) Q:'FILE
 S DD=$G(^DD(FILE,FLD,0)) Q:DD?."^"
 S OPG=$$OTHPG
 ;
 S OPG0=11
 I $G(DDSOLD)]"" D
 . N SUB
 . S SUB=+$P($G(^DD(FILE,DDSOLD,0)),U,2)
 . S:SUB OPG0=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31)
 ;
 S (C,C0)=$$GET^DDSVALF("CAPTION",1,1)
 S:C]"" CC=$$GET^DDSVALF("CAPTION COORDINATE",1,OPG0)
 S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG0)
 ;
 I OPG'=OPG0 D
 . D:C]"" PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC)
 . D:DC]"" PUT^DDSVALF("DATA COORDINATE",1,OPG,DC)
 . D DESTROY^DDSUTL(OPG0)
 . 
 ;
 I $D(DDGFREF),$D(DDGFPG) S PLRC=$P($G(@DDGFREF@("F",DDGFPG)),U,4)
 S PLRC=$S($G(PLRC)]"":PLRC-1,1:IOM-2)-$P($G(@DDGFREF@("F",DDGFPG,DA(1))),U,2)
 S L=$$LENGTH(FILE,FLD) S:'L L=1
 ;
 I C'="!M",$P(DD,U)]"" D
 . S C=$P(DD,U)
 . I $P(DD,U,2),$P($G(^DD(+$P(DD,U,2),.01,0)),U,2)'["W" S C="Select "_C
 . D PUT^DDSVALF("CAPTION",1,1,C)
 . ;
 . I C0="" D
 .. S CC=DC
 .. S $P(DC,",",2)=$P(DC,",",2)+2
 .. D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC)
 . E  Q:$P(CC,",")'=$P(DC,",")
 . ;
 . S $P(DC,",",2)=$P(DC,",",2)+$L(C)-$L(C0)
 . S:$P(DC,",",2)<1 $P(DC,",",2)=1
 . D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC)
 ;
 I C0'="!M",$P(DC,",",2)-2+L>PLRC S L=PLRC-$P(DC,",",2)+2
 D PUT^DDSVALF("DATA LENGTH",1,OPG,L)
 Q
 ;
HBVAL ;Validate hdr blk
 Q:X=""  Q:'$O(@(DIE_DA_",40,""B"",X,"""")"))
 S DDSERROR=1
 D HLP^DDSUTL($C(7)_DDSEXT_" already exists on this page.")
 Q
 ;
LENGTH(DIFILE,DIFLD) ;Find max field length
 N DD,DIIT,DILEN,DITYPE
 S DILEN=""
 S DD=$G(^DD(DIFILE,DIFLD,0)) Q:DD?."^" DILEN
 S DITYPE=$P(DD,U,2),DIIT=$P(DD,U,5,999)
 ;
 I DIIT["$L(X)>" S DILEN=+$P($P(DIIT,"$L(X)>",2,999),"E")
 E  I DITYPE["N" S DILEN=+$P(DITYPE,"J",2)
 E  I DITYPE["P" S DILEN=$$LENGTH(+$P(DITYPE,"P",2),.01)
 ;
 E  I DITYPE["S" D
 . N DICODE,DICODEA,DIPC
 . S DICODE=$P(DD,U,3)
 . F DIPC=1:1 S DICODEA=$P(DICODE,";",DIPC) Q:DICODEA=""  D
 .. S DILEN=$$MAX(DILEN,$L($P(DICODEA,":")),$L($P(DICODEA,":",2)))
 ;
 E  I DITYPE["D" D
 . N DIDT
 . S DIDT=$P($P(DIIT,"S %DT=""",2,999),"""")
 . S DILEN=$S(DIDT["S"&(DIDT["T"):20,DIDT["T":17,1:11)
 ;
 E  I DITYPE["V" D
 . N DIL,DIX
 . S DIX=0 F  S DIX=$O(^DD(DIFILE,DIFLD,"V",DIX)) Q:'DIX  D
 .. Q:'$G(^DD(DIFILE,DIFLD,"V",DIX,0))
 .. S DIL=$G(DIL)+1
 .. S DIL(DIL)=$$LENGTH(+^DD(DIFILE,DIFLD,"V",DIX,0),.01)
 . S DILEN=$G(DIL(1))
 . F DIL=1:1:$G(DIL)-1 S DILEN=$$MAX(DIL(DIL),DIL(DIL+1))
 ;
 E  I DITYPE D
 . Q:$D(^DD(+DITYPE,.01,0))[0
 . S DILEN=$S($P(^DD(+DITYPE,.01,0),U,2)["W":1,1:$$LENGTH(+DITYPE,.01))
 ;
 Q DILEN
 ;
MAX(X,Y,Z) ;Return max of 2 or 3 numbers
 N M
 S M=$S(X>Y:+X,1:+Y),M=$S(M>$G(Z):M,1:+$G(Z))
 Q M

DDGFUPDB
DDGFUPDB ;SFISC/MKO-UPDATE BLOCK COORDINATES ;03:28 PM  17 Aug 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BLK(DDGFORIG) ;
 ;Update image with adjusted block coordinates
 ; DDGFORIG(B) : defined for all blocks that changed coordinates
 ;               = original $Y^original $X
 N P,P1,P2,B,B1,B2,F,C1,C2,C3,C,D1,D2,D3,L,X1,Y1,N,I
 ;
 ;Get page coordinates
 S P=DDGFPG
 S P1=$P(@DDGFREF@("F",P),U),P2=$P(@DDGFREF@("F",P),U,2)
 ;
 ;Loop through all blocks on page
 S B="" F  S B=$O(@DDGFREF@("F",P,B)) Q:B=""  D BK
 Q
 ;
BK ;Get block coordinates
 S B2=@DDGFREF@("F",P,B)
 S B1=$P(B2,U),B2=$P(B2,U,2)
 ;
 ;Get Y1=delta $Y, X1=delta $X
 I $D(DDGFORIG(B)) S Y1=B1-$P(DDGFORIG(B),U),X1=B2-$P(DDGFORIG(B),U,2)
 E  S (Y1,X1)=0
 I 'Y1,'X1 K DDGFORIG(B)
 ;
 ;Loop through all fields on block
 S F="" F  S F=$O(@DDGFREF@("F",P,B,F)) Q:F=""  D FD
 Q
 ;
FD ;
 ;Get field data
 S N=@DDGFREF@("F",P,B,F)
 S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4)
 S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8)
 ;
 I $D(DDGFORIG(B)) D
 . I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1
 . I X1 D
 .. I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1
 .. I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1
 . S @DDGFREF@("F",P,B,F)=N
 . ;
 . I C]"" D
 .. K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")
 .. S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")=""
 . I L D
 .. K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")
 .. S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")=""
 ;
 I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2)
 I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2)
 Q

DDGFUPDP
DDGFUPDP ;SFISC/MKO-UPDATE PAGE COORDINATES ;01:37 PM  19 Jan 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PAGE(P1,P2,P3,P4,T,A) ;
 ;
 D DESTROY^DDGLIBW(DDGFWID,1),DESTROY^DDGLIBW(DDGFWIDB,1)
 I P3]"" D
 . D REPALL^DDGLIBW($G(A))
 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1)
 . S DDGFLIM=P1_U_P2_U_P3_U_P4
 E  D
 . D CLOSEALL^DDGLIBW()
 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2))
 . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2)
 D:T="PTOP" TOP(P1,P2,P3,P4)
 D:T="PBRC" BRC(P1,P2,P3,P4)
 Q
 ;
TOP(P1,P2,P3,P4) ;Update page image
 ;
 N B,C,C1,C2,C3,D1,D2,D3,F,I,L,N,P,X1,Y1
 ;
 S P=DDGFPG
 S N=@DDGFREF@("F",P)
 S Y1=P1-$P(N,U),X1=P2-$P(N,U,2)
 I 'Y1,'X1 Q
 ;
 I $P(N,U,3)]"" D
 . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP")
 . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC")
 I $G(P3)]"" D
 . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
 . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
 ;
 S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1
 S @DDGFREF@("F",P)=N
 ;
 ;Loop through all blocks on page
 S B="" F  S B=$O(@DDGFREF@("F",P,B)) Q:B=""  D
 . S N=@DDGFREF@("F",P,B)
 . S @DDGFREF@("BKRC",DDGFWIDB,$P(N,U)+Y1,$P(N,U,2)+X1,$P(N,U,3)+X1,B)=@DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B)
 . K @DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B)
 . S $P(N,U,1,3)=$P(N,U)+Y1_U_($P(N,U,2)+X1)_U_($P(N,U,3)+X1)
 . S @DDGFREF@("F",P,B)=N
 . ;
 . S F="" F  S F=$O(@DDGFREF@("F",P,B,F)) Q:F=""  D
 .. S N=@DDGFREF@("F",P,B,F)
 .. S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4)
 .. S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8)
 .. ;
 .. I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1
 .. I X1 D
 ... I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1
 ... I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1
 .. S @DDGFREF@("F",P,B,F)=N
 .. ;
 .. I C]"" D
 ... K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")
 ... S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")=""
 .. I L D
 ... K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")
 ... S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")=""
 .. ;
 .. D:C]"" WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2)
 .. D:L WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2)
 Q
 ;
BRC(P1,P2,P3,P4) ;Change bottom right coordinate of page
 N B,C,F,L,N,P
 S P=DDGFPG
 S N=@DDGFREF@("F",P)
 I $P(N,U,3)]"" D
 . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP")
 . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC")
 I $G(P3)]"" D
 . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
 . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
 ;
 S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1
 S @DDGFREF@("F",P)=N
 ;
 ;Loop through all blocks/fields on page
 S B="" F  S B=$O(@DDGFREF@("F",P,B)) Q:B=""  D
 . S F="" F  S F=$O(@DDGFREF@("F",P,B,F)) Q:F=""  D
 .. S N=@DDGFREF@("F",P,B,F)
 .. S C=$P(N,U,4),L=$P(N,U,8)
 .. ;
 .. I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2)
 .. I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2)
 Q

DDGLIB0
DDGLIB0 ;SFISC/MKO-SETUP AND CLEANUP FOR WINDOWS ;09:37 AM  30 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
INIT() ;Setup required variables
 ;Set margin to 0
 ;Turn autowrap off
 ;Turn type-ahead on
 ;Variables set:
 ;  DDGLDEL  = delimiter for other DDGL variables
 ;  DDGLVID  = codes that turn on/off video attributes
 ;  DDGLED   = codes for editing
 ;  DDGLCLR  = codes to erase characters
 ;  DDGLGRA  = codes for graphics characters
 ;  DDGLZOSF = array of code from %ZOSF
 ;  DDGLREF  = global where window image is stored
 ;  DDGLKEY  = codes for non-alphanumeric keys
 ;  DDGLSCR  = array containing list of visible windows on screen
 ;
 N X
 I $D(DDGLDEL)[0 D SET Q:$G(DIERR)
 S X=0 X ^%ZOSF("RM"),^("TYPE-AHEAD")
 W $P(DDGLVID,DDGLDEL,8)
 Q
 ;
SET ;Setup screen handling variables
 K DIERR,DDGLSCR
 S U="^",DDGLDEL=$C(127)
 ;
 F X="EOFF","EON","TRMOFF","TRMON","TRMRD" D  G:$G(DIERR) ABT
 . I $D(^%ZOSF(X))#2 S DDGLZOSF(X)=^(X) Q
 . D BLD^DIALOG(810)
 ;
 S IOP="HOME" D ^%ZIS I POP D BLD^DIALOG(845) G ABT
 I $D(^%ZIS(2)),'$O(^%ZIS(2,+$G(IOST(0)),0)) D BLD^DIALOG(840,"#"_+$G(IOST(0))) G ABT
 ;
 D:$G(IOXY)="" TRMERR("Cursor positioning (XY CRT)")
 ;
 S X="IORVON;IORVOFF;IOELEOL;IOEDEOP;IOUON;IOUOFF;IOSGR0;IOINHI;IOINLOW;IOINORM;IOCUU;IOCUD;IOCUF;IOCUB;IODL;IOIL;IODCH;IOICH;IOEDALL;IOELALL;IORI;IOAWM1;IOAWM0;IOSTBM;IOPF1;IOPF2;IOPF3;IOPF4;IOFIND;IOSELECT;IOINSERT;IOREMOVE;IOPREVSC;IONEXTSC"
 N @$TR(X,";",",")
 N IOBLC,IOBRC,IOBT,IOG1,IOG0,IOHL,IOLT,IOMT,IORT,IOTLC,IOTRC,IOTT,IOVL
 D ENDR^%ZISS,GSET^%ZISS
 I $G(IOPREVSC)="","^C-VT220^C-VT320^"[(U_IOST_U) D
 . S IOPREVSC=$C(27)_"[5~"
 . S IONEXTSC=$C(27)_"[6~"
 ;
 S DDGLVID=IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINORM_DDGLDEL_IOUON_DDGLDEL_IOUOFF_DDGLDEL_IORVON_DDGLDEL_IORVOFF_DDGLDEL_IOAWM0_DDGLDEL_IOAWM1_DDGLDEL_IOSGR0
 S DDGLED=$G(IORI)_DDGLDEL_$G(IOSTBM)_DDGLDEL_$G(IOIL)_DDGLDEL_$G(IODL)_DDGLDEL_$G(IOICH)_DDGLDEL_$G(IODCH)
 S DDGLCLR=IOELEOL_DDGLDEL_IOEDALL_DDGLDEL_IOEDEOP_DDGLDEL_$G(IOELALL)
 S DDGLKEY=U_IOCUU_U_IOCUD_U_IOCUF_U_IOCUB_U_IOPF1_U_IOPF2_U_IOPF3_U_IOPF4_U_$G(IOFIND)_U_$G(IOSELECT)_U_$G(IOINSERT)_U_$G(IOREMOVE)_U_$G(IOPREVSC)_U_$G(IONEXTSC)_U
 S DDGLGRA=IOG1_DDGLDEL_IOG0_DDGLDEL_IOHL_DDGLDEL_IOVL_DDGLDEL_IOTLC_DDGLDEL_IOTRC_DDGLDEL_IOBLC_DDGLDEL_IOBRC
 S:DDGLDEL_$P(DDGLGRA,DDGLDEL,3,999)_DDGLDEL[(DDGLDEL_DDGLDEL) DDGLGRA=DDGLDEL_DDGLDEL_"-"_DDGLDEL_"|"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+"
 ;
 D:$P(DDGLKEY,U,1,5)_U[(U_U) TRMERR("Cursor keys")
 D:U_$P(DDGLKEY,U,6,9)_U[(U_U) TRMERR("PF keys")
 D:IOELEOL="" TRMERR("Erase to End of Line")
 D:IOEDALL="" TRMERR("Erase Entire Page")
 D:IOEDEOP="" TRMERR("Erase to End of Page")
 G:$G(DIERR) ABT
 ;
 S DDGLREF="^TMP(""DDGL"",$J,""W"")" K @DDGLREF
 ;
 I "^C-QUME^C-QVT102^C-WYSE75^"[(U_$TR(IOST," ","")_U) D
 . S DDGLVAN=1
 . S $P(DDGLVID,DDGLDEL,4,7)=$S($TR(IOST," ","")="C-WYSE75":IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW,1:IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI)
 . S $P(DDGLVID,DDGLDEL,10)=IOINORM
 ;
 D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS
 Q
 ;
TRMERR(DDGLCH) ;Terminal type errors
 N P
 S P(1)=DDGLCH,P(2)=IOST
 D BLD^DIALOG(842,.P)
 Q
 ;
KILL(DDGLPARM) ;Cleanup variables
 ;Set margin to IOM
 ;Turn off type-ahead if New Person file so indicates
 ;Turn autowrap on
 ;Reset character attributes
 ;Turn echo on
 ;Turn terminators off
 N X
 I $G(DDGLPARM)'["W" D
 . S X=$S($D(IOM)#2:IOM,1:80) X $G(^%ZOSF("RM"))
 . I $D(DUZ)#2,$D(^VA(200,DUZ,0))#2,$P($G(^(200)),U,9)'="Y" D
 .. I '$G(DUZ("BUF"),1) X $G(^%ZOSF("NO-TYPE-AHEAD"))
 . W $P($G(DDGLVID),$G(DDGLDEL),9),$P($G(DDGLVID),$G(DDGLDEL),10)
 ;
 I $G(DDGLPARM)'["T" D
 . X $G(DDGLZOSF("EON")),$G(DDGLZOSF("TRMOFF"))
 E  X $G(DDGLZOSF("EOFF")),$G(DDGLZOSF("TRMON"))
 ;
ABT K DX,DY,POP
 I '$G(DIERR),$G(DDGLPARM)["K" Q
 K:$G(DDGLREF)]"" @DDGLREF
 D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS
 ;
 K DDGLDEL,DDGLVID,DDGLED,DDGLCLR,DDGLGRA,DDGLZOSF,DDGLREF
 K DDGLKEY,DDGLSCR,DDGLVAN,DDGLH
 ;
 K DIR0
 Q

DDGLIBH
DDGLIBH ;SFISC/MKO-SCREEN EDITOR HELP ;08:00 AM  23 Feb 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
HLP(DDGLHN1,DDGLHN2,DDGLSUB,DDGLPLN) ;
 ;DDGLHN1  = Entry number in Dialog file of first help screen
 ;DDGLHN2  = Entry number of last help screen
 ;DDGLSUB  = Subscript in ^TMP to copy help to
 ;DDGLPLN  = $Y to print prompt
 ;
 N DX,DY,DDGLI,DDGLJ,DDGLSC,DDGLTX,DDGLX,DIHELP,DDGL0
 S DDGL0=$C(31)
 D:'$D(DDGLH) GETKEY
 I $D(IOTM)[0 N IOTM S IOTM=1
 I $D(IOBM)[0 N IOBM S IOBM=IOSL
 I '$G(DDGLPLN) S DDGLPLN=IOBM-1
 S DDGLSC=DDGLHN1
 ;
 D DISP(DDGLHN1)
 ;
 F  S DDGLX=$$READ D @DDGLX Q:DDGLX=U
 Q
 ;
UP I DDGLSC>DDGLHN1 S DDGLSC=DDGLSC-1 D DISP(DDGLSC)
 Q
 ;
DN I DDGLSC<DDGLHN2 S DDGLSC=DDGLSC+1 D DISP(DDGLSC)
 Q
 ;
TO W $C(7)
QT S DDGLX=U
 Q
 ;
PT ;Prompt for device and print
 ;Clear screen
 N POP
 N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N
 N %P,%S,%T,%W,%X,%Y
 N %A0,%D1,%D2,%DT,%J1,%W0
 ;
 S DY=IOTM-1,DX=0 X IOXY
 W $P(DDGLVID,DDGLDEL)_"PRINT THE HELP SCREENS"_$P(DDGLVID,DDGLDEL,10)_$P(DDGLCLR,DDGLDEL)
 F DDGLI=1:1:IOBM-IOTM W $C(13,10)_$P(DDGLCLR,DDGLDEL)
 S DY=IOTM+1,DX=0 X IOXY
 ;
 X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
 S X=$G(IOM,80) X ^%ZOSF("RM")
 W $P(DDGLVID,DDGLDEL,9)
 ;
DEVICE ;Device prompt
 N IOF,IOSL
 S IOF="#",IOSL=IOBM-IOTM+1 ;In case help frames are invoked
 S %ZIS=$S($D(^%ZTSK):"Q",1:""),%ZIS("B")=""
 D ^%ZIS K %ZIS
 ;
 I POP D
 . W !!,"Report canceled!"
 . H 2
 ;
 ;Queue report
 E  I $D(IO("Q")),$D(^%ZTSK) D
 . S ZTRTN="PRINT^DDGLIBH"
 . S ZTDESC="Help screen printout."
 . N I F I="DDGLHN1","DDGLHN2" S ZTSAVE(I)=""
 . D ^%ZTLOAD
 . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_ZTSK,!
 . E  W !,"Report canceled!",!
 . K ZTSK
 . S IOP="HOME" D ^%ZIS
 ;
 E  I $E(IOST,1,2)="C-" D  G DEVICE
 . W !,$C(7)_"You cannot print the help screens on a CRT.",!
 ;
 ;Non-queued report
 E  D
 . W !,"Printing ..."
 . U IO
 . D PRINT
 . X $G(^%ZIS("C"))
 ;
 ;Repaint help screen
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 S X=0 X ^%ZOSF("RM")
 W $P(DDGLVID,DDGLDEL,8)
 D DISP(DDGLSC)
 Q
 ;
PRINT ;
 N DDGLJ,DDGLL,DDGLP
 F DDGLI=DDGLHN1:1:DDGLHN2 D
 . I DDGLI'=DDGLHN1 D
 .. I $Y+$O(^DI(.84,DDGLI,2," "),-1)+2'<IOSL W @IOF
 .. E  W !!
 . S DDGLJ=0
 . F  S DDGLJ=$O(^DI(.84,DDGLI,2,DDGLJ)) Q:'DDGLJ  D
 .. S DDGLL=$G(^DI(.84,DDGLI,2,DDGLJ,0))
 .. F  Q:DDGLL'["\"  D
 ... S DDGLP=$F(DDGLL,"\") Q:$E(DDGLL,DDGLP)="\"
 ... S $E(DDGLL,DDGLP-1,DDGLP)=""
 .. W !,DDGLL
 ;
 S:$D(ZTQUEUED) ZTREQ="@"
 Q
 ;
DISP(DDGLHN) ;Print help screen DDGLHN
 N DDGLHARR
 S DDGLHARR=$NA(^TMP(DDGLSUB,$J,DDGLHN))
 D:'$D(@DDGLHARR) BLD^DIALOG(DDGLHN,"","",DDGLHARR)
 ;
 S DY=IOTM-1,DX=0 X IOXY
 F DDGLI=1:1 Q:'$D(@DDGLHARR@(DDGLI))  S DDGLTX=^(DDGLI) D
 . I DDGLTX["\B" F  S DDGLJ=$F(DDGLTX,"\B") Q:'DDGLJ  D
 .. S $E(DDGLTX,DDGLJ-2,DDGLJ-1)=$P(DDGLVID,DDGLDEL)
 . I DDGLTX["\n" F  S DDGLJ=$F(DDGLTX,"\n") Q:'DDGLJ  D
 .. S $E(DDGLTX,DDGLJ-2,DDGLJ-1)=$P(DDGLVID,DDGLDEL,10)
 . W $S(DDGLI>1:$C(13,10),1:"")_DDGLTX_$P(DDGLCLR,DDGLDEL)
 ;
 F DDGLI=DDGLI:1:IOBM-IOTM+1 W $C(13,10)_$P(DDGLCLR,DDGLDEL)
 Q
 ;
READ() ;
 S DY=DDGLPLN,DX=0 X IOXY
 W $P(DDGLCLR,DDGLDEL)_"Press "
 W:DDGLSC>DDGLHN1 $P(DDGLVID,DDGLDEL)_"<Up>"_$P(DDGLVID,DDGLDEL,10)_" for previous page, "
 W:DDGLSC<DDGLHN2 $P(DDGLVID,DDGLDEL)_"<Down>"_$P(DDGLVID,DDGLDEL,10)_" for next page, "
 W $P(DDGLVID,DDGLDEL)_"P"_$P(DDGLVID,DDGLDEL,10)_" to print, "
 W $P(DDGLVID,DDGLDEL)_"^"_$P(DDGLVID,DDGLDEL,10)_" to exit: "
 D GETCH(DTIME,.DDGLX)
 S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)
 Q DDGLX
 ;
GETCH(DTIME,Y) ;Out: Y = Mnemonic
 F  D  Q:Y'=-1
 . R *Y:DTIME
 . I Y<0 S Y="TO" Q
 . D MNE(.Y)
 Q
 ;
MNE(Y) ;Out: Y = Mnemonic, or -1 if invalid
 N S,F
 S S="",F=0
 F  D MNELOOP Q:F
 Q
 ;
MNELOOP ;Read more
 S S=S_$C(Y)
 I DDGLH("IN")'[(DDGL0_S) D  I Y=-1 D FLUSH Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32)
 . S:DDGLH("IN")'[(DDGL0_S_DDGL0) Y=-1
 ;
 I DDGLH("IN")[(DDGL0_S_DDGL0),S'=$C(27) D  Q
 . S Y=$P(DDGLH("OUT"),DDGL0,$L($P(DDGLH("IN"),DDGL0_S_DDGL0),DDGL0)),F=1
 ;
 R *Y:5 D:Y=-1 FLUSH
 Q
 ;
FLUSH ;
 N DDGLZ
 S F=1 W $C(7) F  R *DDGLZ:0 E  Q
 Q
 ;
GETKEY ;Get key sequences and defaults
 N AU,AD,F1,PREVSC,NEXTSC
 N I,K,N,T
 S AU=$P(DDGLKEY,U,2)
 S AD=$P(DDGLKEY,U,3)
 S F1=$P(DDGLKEY,U,6)
 S PREVSC=$P(DDGLKEY,U,14)
 S NEXTSC=$P(DDGLKEY,U,15)
 ;
 K DDGLH
 S DDGLH("IN")="",DDGLH("OUT")=""
 F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T=""  D
 . S @("K="_$P(T,";",2))
 . I DDGLH("IN")'[(DDGL0_K),K]"" D
 .. S DDGLH("IN")=DDGLH("IN")_DDGL0_K
 .. S DDGLH("OUT")=DDGLH("OUT")_$P(T,";")_DDGL0
 S DDGLH("IN")=DDGLH("IN")_DDGL0
 S DDGLH("OUT")=$E(DDGLH("OUT"),1,$L(DDGLH("OUT"))-1)
 Q
 ;
MAP ;Keys
 ;;DN;$C(13)
 ;;DN;AD
 ;;DN;F1_AD
 ;;DN;NEXTSC
 ;;UP;AU
 ;;UP;F1_AU
 ;;UP;PREVSC
 ;;QT;F1_"E"
 ;;QT;F1_"Q"
 ;;QT;"^"
 ;;PT;"P"

DDGLIBW
DDGLIBW ;SFISC/MKO-WINDOW PRIMITIVES ;02:24 PM  13 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; Area is defined as $Y^$X^height^width
 ; DDGLREF(wid)=$Y^$X^height^width
 ; DDGLREF(wid,$Y+1,"TXT")=string
 ; DDGLREF(wid,$Y+1,"ATT")=attributes (bold,underline,reverse,graphic)
 ;
 ; DDGLSCR array - keeps track of what windows are on the screen and
 ;                the order in which they overlap
 ; Form of DDGLSCR array:
 ;   DDGLSCR           = # of elements
 ;   DDGLSCR(n)        = wid
 ;   DDGLSCR("B",wid,n)= ""
 ;
CREATE(I,A,B,N) ;
 G CREATE1^DDGLIBW1
 ;
OPEN(I,N) ;
 G OPEN1^DDGLIBW1
 ;
FOCUS(I,N) ;
 G FOCUS1^DDGLIBW1
 ;
CLOSE(I,NC) ;
 G CLOSE1^DDGLIBW1
 ;
CLEAR(I,A) ;
 ;Clear area A in window I
 G CLEAR1^DDGLIBW1
 ;
EXIST(I) ;
 ;Does window I exist?
 Q $D(@DDGLREF@(I))#2
 ;
CLOSEALL(N) ;
 ;Close all windows
 W:'$G(N) $P(DDGLCLR,DDGLDEL,2)
 K DDGLSCR
 Q
 ;
DESTROY(I,NC) ;
 ;Destroy window I
 D CLOSE(I,$G(NC))
 K @DDGLREF@(I)
 Q
 ;
DESTALL ;Destroy all windows
 K @DDGLREF,DDGLSCR
 Q
 ;
WRITE(I,S,Y,X,A,N) ;
 ;Write str S in window I at $Y=R, $X=C, attr A
 ; If N=1, update buffer, but don't write
 N A1,A0,A9
 Q:$G(S)=""
 S:$G(I)="" I=-1
 S A9=$$AREA(I)
 Q:X'<$P(A9,U,4)  Q:Y'<$P(A9,U,3)
 S S=$E(S,1,$P(A9,U,4)-X)
 ;
 S $E(@DDGLREF@(I,Y+1,"TXT"),X+1,X+$L(S))=S
 I $G(A)="",$D(@DDGLREF@(I,Y+1,"ATT"))#2 S $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$J("",$L(S))
 S:$G(A)]"" $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$TR($J("",$L(S))," ",$$CODE(A,.A1,.A0))
 ;
 I '$G(N) D
 . N DY,DX
 . S DY=Y+$P(A9,U),DX=X+$P(A9,U,2) X IOXY W $G(A1)_S_$G(A0)
 ;
 I $G(@DDGLREF@(I,Y+1,"TXT"))?." ",$G(@DDGLREF@(I,Y+1,"ATT"))?." " K @DDGLREF@(I,Y+1,"TXT"),@DDGLREF@(I,Y+1,"ATT")
 Q
 ;
REPALL(A) ;
 ;Repaint absolute area A in all windows in DDGLSCR array
 N J
 I $G(A)="" D
 . W $P(DDGLCLR,DDGLDEL,2)
 . F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J))
 E  D
 . D CLEAR(-1,A)
 . F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J),$$RELAREA(DDGLSCR(J),A))
 Q
 ;
REPAINT(I,A) ;
 ;Repaint area A of window I
 N X,Y,H,W,R,C,T,X1,X2,A2,A1,A0,S,DY,DX,P
 I $D(A),A="" Q
 S:$G(I)="" I=-1
 S:'$D(A) A="0^0^"_IOSL_U_IOM
 ;
 S A2=$$AREA(I)
 S A=$P(A,U)+$P(A2,U)_U_($P(A,U,2)+$P(A2,U,2))_U_$P(A,U,3,4)
 S A=$$INTSECT^DDGLIBW1(A,A2)
 S Y=$P(A,U)-$P(A2,U),X=$P(A,U,2)-$P(A2,U,2),H=$P(A,U,3),W=$P(A,U,4)
 ;
 I $D(@DDGLREF@(I))<9,Y+$P(A2,U)=0,X+$P(A2,U,2)=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q
 S P=IOM-X-$P(A2,U,2)-1_""" """
 F R=Y+1:1:Y+H D
 . S S=""
 . S T=$E($G(@DDGLREF@(I,R,"TXT"))_$J("",X+W-$L($G(@DDGLREF@(I,R,"TXT")))),1,X+W)
 . S A=$E($G(@DDGLREF@(I,R,"ATT")),1,X+W)
 . S (X1,X2)=X+1 F  D  Q:$E(T,X2)=""
 .. S X1=X2,C=$E(A,X1)
 .. I C="" S X2=999 S S=S_$E(T,X1,X2) Q
 .. F X2=X1:1:$L(A)+1 Q:C'=$E(A,X2)
 .. D DECODE(C,.A1,.A0)
 .. S S=S_A1_$E(T,X1,X2-1)_A0
 . S DY=R-1+$P(A2,U),DX=X+$P(A2,U,2) X IOXY
 . W $S(S?@P:$P(DDGLCLR,DDGLDEL),1:S)
 Q
 ;
BOX(I,A,C,N) ;
 ;Draw a box in window I representing area A
 ;If C=1 writes spaces within the box
 ;If N=1 write to buffer but not screen
 N Y,X,H,W,L,R,S,A1
 S:$G(I)="" I=-1
 S:$G(A)="" A=$$AREA(I)
 S:$G(N)="" N=0
 S A1=$$ABSAREA(I,A)
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 Q:'H!'W
 S S=$J("",W-2),L=$TR(S," ",$P(DDGLGRA,DDGLDEL,3))
 D WRITE(I,$P(DDGLGRA,DDGLDEL,5)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,6),1:""),Y,X,"G",N)
 F R=Y+1:1:Y+H-2 D
 . D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X,"G",N)
 . I W>1 D
 .. I $G(C) D WRITE(I,S,R,X+1,"",N)
 .. D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X+W-1,"G",N)
 D:H>1 WRITE(I,$P(DDGLGRA,DDGLDEL,7)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,8),1:""),Y+H-1,X,"G",N)
 Q
 ;
ABSAREA(I,A) ;
 ;Given relative area A in window I, return absolute area
 N X,Y,H,W,X1,Y1
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 S A=$$AREA(I)
 S Y1=Y+$P(A,U),X1=X+$P(A,U,2)
 S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1
 Q Y1_U_X1_U_H_U_W
 ;
RELAREA(I,A) ;
 ;Given absolute area A in window I, return relative area
 N X,Y,H,W,X1,Y1
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 S A=$$AREA(I)
 S Y1=Y-$P(A,U),X1=X-$P(A,U,2)
 Q Y1_U_X1_U_H_U_W
 ;
AREA(I) ;Return the coord and area of window I
 Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM)
 ;
CODE(A,A1,A0) ;
 ;Return code char for selected attr
 N I,C,T
 S C=0,(A1,A0)=""
 S T=$TR(A,"burg","BURG")
 F I=1:1:$L(A) D
 . S T=$T(@$E(A,I))
 . I T]"" D
 .. S C=C+$P(T,";",3)
 .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5))
 .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6))
 Q $C(C+32)
 ;
DECODE(C,A1,A0) ;
 ;Given code char C, return codes to turn on/off attr
 N B,T
 S (A1,A0)="" Q:" "[$G(C)
 S C=$A(C)-32
 S B=1 F  D  Q:B>8
 . I C\B#2,$T(@B)]"" D
 .. S T=$T(@B+1)
 .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5))
 .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6))
 . S B=B*2
 Q
 ;
1 ;;
B ;;1;DDGLVID;1;2
2 ;;
U ;;2;DDGLVID;4;5
4 ;;
R ;;4;DDGLVID;6;7
8 ;;
G ;;8;DDGLGRA;1;2

DDGLIBW1
DDGLIBW1 ;SFISC/MKO-WINDOWING PRIMITIVES ;02:23 PM  13 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CREATE(I,A,B,N) ;
CREATE1 ;Create window I of area A and draw border (if B)
 ;N = nn; first n=1 means don't give the window focus
 ;        second n=1 means don't write to screen
 ;
 S:$G(I)="" I=-1
 S:$G(A)="" A="0^0^"_IOSL_U_IOM
 K @DDGLREF@(I) S @DDGLREF@(I)=A
 D:$G(B) BOX^DDGLIBW(I,"0^0^"_$P(A,U,3,4),1,$G(N))
 D:$G(N)<9 FOCUS(I,$G(N)!$G(B))
 Q
 ;
OPEN(I,N) ;
OPEN1 ;Open window I
 G FOCUS1
 ;
FOCUS(I,N) ;
FOCUS1 ;Give focus to window I
 ;If N=1; don't paint window
 Q:$D(@DDGLREF@(I))[0
 Q:$G(DDGLSCR(+$G(DDGLSCR)))=I
 ;
 I '$D(DDGLSCR("B",I)) D
 . S DDGLSCR=$G(DDGLSCR)+1,DDGLSCR(DDGLSCR)=I,DDGLSCR("B",I,DDGLSCR)=""
 E  D
 . N M,N
 . S DDGLSCR(DDGLSCR+1)=I
 . S M=$O(DDGLSCR("B",I,""))
 . F N=M:1:DDGLSCR D
 .. K DDGLSCR("B",DDGLSCR(N),N)
 .. S DDGLSCR(N)=DDGLSCR(N+1)
 .. S DDGLSCR("B",DDGLSCR(N),N)=""
 . K DDGLSCR(DDGLSCR+1)
 D:'$G(N) REPAINT^DDGLIBW(I)
 Q
 ;
CLOSE(I,NC) ;
CLOSE1 ;Close window I
 N A,M,N,W
 S M=$O(DDGLSCR("B",I,""))
 Q:M=""
 ;
 I '$G(NC) D
 . S A=$$AREA(I)
 . D CLEAR(I,"0^0^"_$P(A,U,3,4))
 . F N=1:1:DDGLSCR D:N'=M
 .. S W=DDGLSCR(N)
 .. D REPAINT^DDGLIBW(W,$$RELAREA(W,$$INTSECT($$AREA(W),A)))
 ;
 F N=M:1:DDGLSCR-1 D
 . K DDGLSCR("B",DDGLSCR(N),N)
 . S DDGLSCR(N)=DDGLSCR(N+1)
 . S DDGLSCR("B",DDGLSCR(N),N)=""
 K DDGLSCR("B",DDGLSCR(DDGLSCR),DDGLSCR),DDGLSCR(DDGLSCR)
 S DDGLSCR=DDGLSCR-1
 Q
 ;
CLEAR(I,A) ;
CLEAR1 ;Clear area A in window I
 N Y,X,H,W,S,DY,DX
 S:$G(I)="" I=-1 S:$G(A)="" A=$$AREA(I)
 S A=$$ABSAREA(I,A)
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 I Y=0,X=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q
 S DX=X,S=$S(IOM-X=W:$P(DDGLCLR,DDGLDEL),1:$J("",W))
 F DY=Y:1:Y+H-1 X IOXY W S
 Q
 ;
ABSAREA(I,A) ;
 ;Given relative area A in window I, return absolute area
 N X,Y,H,W,X1,Y1
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 S A=$$AREA(I)
 S Y1=Y+$P(A,U),X1=X+$P(A,U,2)
 S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1
 Q Y1_U_X1_U_H_U_W
 ;
RELAREA(I,A) ;
 ;Given absolute area A in window I, return relative area
 N X,Y,H,W,X1,Y1
 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
 S A=$$AREA(I)
 S Y1=Y-$P(A,U),X1=X-$P(A,U,2)
 Q Y1_U_X1_U_H_U_W
 ;
AREA(I) ;Return the coord and area of window I
 Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM)
 ;
INTSECT(A1,A2) ;
 ;Return the intersection of areas 1 and 2
 N A,X1,Y1,H1,W1,X2,Y2,H2,W2
 S Y1=$P(A1,U),X1=$P(A1,U,2),H1=$P(A1,U,3),W1=$P(A1,U,4)
 S Y2=$P(A2,U),X2=$P(A2,U,2),H2=$P(A2,U,3),W2=$P(A2,U,4)
 S A=""
 S $P(A,U)=$$MAX(Y1,Y2),$P(A,U,2)=$$MAX(X1,X2)
 S $P(A,U,3)=$$LEN(Y1,H1,Y2,H2)
 S $P(A,U,4)=$$LEN(X1,W1,X2,W2)
 Q:'$P(A,U,3)!'$P(A,U,4) ""
 Q A
 ;
MAX(X,Y) ;
 ;Return the max of X and Y
 Q $S(X>Y:X,1:Y)
 ;
LEN(C1,L1,C2,L2) ;
 ;Return intersection length of two lines
 ; C = position along X or Y axis
 ; L = length of line
 Q:C1'>C2 $S(C1+L1'<(C2+L2):L2,C1+L1>C2:L1-C2+C1,1:0)
 Q $S(C2+L2'<(C1+L1):L1,C2+L2>C1:L2-C1+C2,1:0)

DDIOL
DDIOL ;SFISC/MKO-THE LOADER ;1:53 PM  12 Sep 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN(A,G,FMT) ;Write the text contained in local array A or global array G
 ;If one string passed, use format FMT
 N %,Y,DINAKED
 S DINAKED=$$LGR^%ZOSV
 ;
 S:'$D(A) A=""
 I $G(A)="",$D(A)<9,$G(FMT)="",$G(G)'?1"^"1A.7AN,$G(G)'?1"^"1A.7AN1"(".E1")" Q
 ;
 G:$D(DDS) SM
 G:$D(DIQUIET) LD
 ;
 N F,I,S
 I $D(A)=1,$G(G)="" D
 . S F=$S($G(FMT)]"":FMT,1:"!")
 . W @F,A
 ;
 E  I $D(A)>9 S I=0 F  S I=$O(A(I)) Q:I'=+$P(I,"E")  D
 . S F=$G(A(I,"F"),"!") S:F="" F="?0"
 . W @F,$G(A(I))
 ;
 E  S I=0 F  S I=$O(@G@(I)) Q:I'=+$P(I,"E")  D
 . S S=$G(@G@(I,0),$G(@G@(I)))
 . S F=$G(@G@(I,"F"),"!") S:F="" F="?0"
 . W @F,S
 ;
 I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))
 Q
 ;
LD ;Load text into ^TMP
 N I,N,T
 S T=$S($G(DDIOLFLG)["H":"DIHELP",1:"DIMSG")
 S N=$O(^TMP(T,$J," "),-1)
 ;
 I $D(A)=1,$G(G)="" D
 . D LD1(A,$S($G(FMT)]"":FMT,1:"!"))
 ;
 E  I $D(A)>9 S I=0 F  S I=$O(A(I)) Q:I'=+$P(I,"E")  D
 . D LD1($G(A(I)),$G(A(I,"F"),"!"))
 ;
 E  S I=0 F  S I=$O(@G@(I)) Q:I'=+$P(I,"E")  D
 . D LD1($G(@G@(I),$G(@G@(I,0))),$G(@G@(I,"F"),"!"))
 ;
 K:'N @T S:N @T=N
 I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))
 Q
 ;
LD1(S,F) ;Load string S, with format F
 ;In: N and T
 N C,J,L
 S:S[$C(7) S=$TR(S,$C(7),"")
 F J=1:1:$L(F,"!")-1 S N=N+1,^TMP(T,$J,N)=""
 S:'N N=1
 S:F["?" @("C="_$P(F,"?",2))
 S L=$G(^TMP(T,$J,N))
 S ^TMP(T,$J,N)=L_$J("",$G(C)-$L(L))_S
 Q
 ;
SM ;Print text in ScreenMan's Command Area
 I $D(DDSID),$D(DTOUT)!$D(DUOUT) G SMQ
 N DDIOL
 S DDIOL=1
 ;
 I $D(A)=1&($G(G)="")!($D(A)>9) D
 . D MSG^DDSMSG(.A,"",$G(FMT))
 E  I $D(@G@(+$O(@G@(0)),0))#2 D
 . D WP^DDSMSG(G)
 E  D HLP^DDSMSG(G)
 ;
SMQ I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))
 Q

DDMAP
DDMAP ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN POINTER RELATIONS ;4/23/93  15:30;7/1/93  4:14 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;EXPLANATIONS:
 ; N =  normal reference
 ; S =  pointer file not included in the set
 ; C =  cross reference in the pointer file
 ; L =  laygo allowed
 ; * =  reference internally truncated
 ; m =  Multiple field
 ; v =  Variable Pointer
 ;
ST S DDPCK=1 I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",9.4,0)):1,1:$D(^DIC(3,DUZ,"FOF",9.4,0))) G INFO:$P(^(0),U,2),EN1
 I DUZ(0)'="@",$D(^DIC(9.4,0,"DD")) S DDPCK=0 F I=1:1:$L(^("DD")) I DUZ(0)[$E(^("DD"),I) S DDPCK=1 Q
 I 'DDPCK G EN1
INFO W !!,"Prints a graph of pointer relations in a database of FileMan files",!,"named in the Kernel PACKAGE file (9.4) or given separately.",!,"Works best with 132 column output!"
DDPCK D DT^DICRW K ^UTILITY($J),DDTO,DDPCK,DUOUT,DTOUT S DDPCKN="" G GET:'$D(^DD(9.4)) S DIC=9.4,DIC(0)="AEQML" D ^DIC G END:X[U!$D(DTOUT),GET:Y<0 S DDPCK=+Y,DDPCKN=$P(Y,U,2)
 S DDFLE="" F I=1:1 S DDFLE=$O(^DIC(9.4,DDPCK,4,"B",DDFLE)) Q:DDFLE=""  S ^UTILITY($J,"F",DDFLE)=""
 G GET:DDPCKN="" D LIST
REM S DIC=1,DIC(0)="AEMQ",DIC("S")="I $D(^UTILITY($J,""F"",+Y)) Q",DIC("A")="Remove FILE: " D ^DIC G:X[U!$D(DTOUT) END G:Y<0 ADD K ^UTILITY($J,"F",+Y) G REM
GET I DDPCKN="" W !!,"Enter files to be included"
ADD K DIC I DUZ(0)'="@" S DIC("S")="I 1 Q:'$D(^(0,""DD""))  F DC=1:1:$L(^(""DD"")) I DUZ(0)[$E(^(""DD""),DC) Q" D ADD0
 S DIC=1,DIC(0)="QEAM",DIC("A")="Add FILE: " D ^DIC G END:X[U!$D(DTOUT),ADD1:Y<0 S ^UTILITY($J,"F",+Y)="" G ADD
ADD0 I $D(^VA(200,"AFOF")) S DIC("S")="I $D(^VA(200,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
 I $D(^DIC(3,"AFOF")) S DIC("S")="I $D(^DIC(3,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q"
 Q
ADD1 G END:'$D(^UTILITY($J)) D:DDPCKN="" LIST
GO G END:'$D(^UTILITY($J)) W !,"Enter name of file group for optional graph header: " W:DDPCKN]"" DDPCKN,"// " R X:DTIME G:X[U!'$T END I X'[U,X]"",($L(X)<3!($L(X)>20)) W:X'["?" $C(7) G HLP1:X["?",HLP
 S:X="" X=DDPCKN S DDPCKN=X W !
EXIT S %ZIS="Q" D ^%ZIS G:POP EXIT1 S DDFLE=0
 I $D(IO("Q")) S ZTRTN="NXF^DDMAP2" F I="^UTILITY($J,","DDFLE","DDPCKN" S ZTSAVE(I)=""
 I $D(IO("Q")) D ^%ZTLOAD G EXIT1
 U IO G ^DDMAP2
EN1 W !," Access NOT Permitted for this Routine.",!,"(Must have DD Access to the PACKAGE File)"
END K DIC,DDFLE,DDPCKN,DDPCK,^UTILITY($J) Q
EXIT2 I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK G KILL
EXIT1 I $D(DD9),IO=IO(0) R !,"Enter '^' to exit or return to continue: ",X:$S($D(DTIME):DTIME,1:300) I $T,X'=U D KILL W @IOF G ST
KILL W:$Y @IOF X $G(^%ZIS("C"))
 K ^UTILITY($J),DDA1,DDA2,DDCR,DIC,DDFL,DDFLD,DDFLE,DDFNMAX,DDFRN,DDFPT,I,DDINC,DDLGO,DDLN,DDMAX,DDOUT,DD5,DD7,DD9,DDP,DDPCK,DDPCKN,DDPP
 K %H,%ZISI,%,DISYS,DDPT,DDPTF,DDTB1,DDTB2,DDTO,DDW,X,Y,%T,%XX,%YY,ZTSK,DDMIOSL,DDMAPC
 Q
LIST W !!,"Files included" S DDFLE=0 F I=1:1 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) Q:DDFLE'>0  W ?27,$J(DDFLE,10),"  ",$O(^DD(DDFLE,0,"NM","")),!
 Q
HLP1 W !,"Type a header that can be used for the print out"
HLP W !,"The Header must be between 3 and 20 characters" G GO

DDMAP1
DDMAP1 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;5/3/91  8:19 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NXF S DDFLE=$O(^UTILITY($J,"FD",DDFLE)) G EXIT2^DDMAP:DDFLE'>0 S DDLN=1,DDOUT=0,DD9=0 I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT)
 D VIIVA^DDMAP2,TO S DDPCK=$O(^DD(DDFLE,0,"NM","")) D FSHORT W ?DDTB1,"|  ",DDFLE," ",DDPCK W ?DDTB2,"|",! S DDFL="" I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT)
NXFL S DDFL=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL)),DDFLD=0 I DDFL="" G END
NXFLD S DDFLD=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD)),DDFPT=0,DD5=DDFL G:DDFLD'>0 NXFL S DDFRN=$P(^DD(DDFL,DDFLD,0),U,1)
NXUP I $D(^DD(DD5,0,"UP")) S DD5=^("UP"),DD7=$O(^("NM","")) S:(DD5'=$P(DDFRN,":",1)) DDFRN=DD7_":"_DDFRN G NXUP
NXPT S DDFPT=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD,DDFPT)) G NXFLD:DDFPT'>0 S DDA2=^(DDFPT) D TO
REV S DDA1=$S($P(DDA2,U,2)["M":"m",1:""),DDA2=$S($P(DDA2,U,2)["V":"v",1:""),DDMAX=DDFNMAX,DDP=DDFRN D SHORT W ?DDTB1,"| " W:DDP]"" DDA2,DDA1,?DDTB1+4,DDP W ?DDTB2,"|" D OUT S DDFRN="" I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT)
 G NXPT
FSHORT I DDFNMAX-$L(DDFLE)-$L(DDPCK)<0 S DDPCK=$E(DDPCK,1,DDFNMAX-$L(DDFLE)-1)_"*"
 Q
SHORT Q:$L(DDP)'>DDMAX  S DDPP=$L(DDP,":"),DD5=DDP I DDPP>1 S DD7=DDMAX-DDPP\DDPP,DD5=$E($P(DDP,":",1),1,DD7) F I=2:1:DDPP S DD5=DD5_":"_$E($P(DDP,":",I),1,DD7)
 S DDP=$E(DD5,1,DDMAX-1)_"*" Q
OUT ;
 W "->",$P(DDFPT," ",2) W " " S DDP=$S($O(^DD(DDFPT,0,"NM",0))]"":$O(^(0)),1:"*** NONEXISTENT FILE ***"),DDMAX=IOM-$X D SHORT W DDP,!
 Q
TO S DDP="",(DDCR,DDINC)=0 Q:'$D(^UTILITY($J,"FD",DDFLE,"TO",DDLN))  S DDPT=$O(^(DDLN,"")),DDPTF=$O(^(DDPT,"")),DDA1=$S($D(^(DDPTF)):^(DDPTF),1:""),DDLN=DDLN+1 I DDPT'>0 S DDP="*** NONEXISTENT FILE ***" G TOOK
 I '$D(^DD(DDPT)) S DDP="*** NONEXISTENT FILE ***" G TOOK
 S DDPTF=+DDPTF,DDTO=DDPT,DDPP=$P(DDA1,U,1)
TOUP S DD5=$O(^DD(DDTO,0,"NM","")) I $D(^DD(DDTO,0,"UP")) S DDTO=^("UP") S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP G TOUP
 S DDINC=$D(^UTILITY($J,"F",DDTO)),DDLGO=$P(DDA1,U,2)'["'",DDA1=$P(DDA1,U,2)["V" S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP
 S DDCR=0,DD5="",DD7=DDPT,DDP=DDPP S:DD7?.E1"."2N DD7=+$P(DD7,".",1,$L(DD7,".")-1) F I=1:1 S DD5=$O(^DD(DD7,0,"IX",DD5)) Q:DD5=""  I $D(^DD(DD7,0,"IX",DD5,DDPT,DDPTF)) S DDCR=1
TOOK I $L(DDP)>0 S DDMAX=DDTB1-15,DD5=$P(DDP,":",1),DD7=DDP D EXT,SHORT S DDW=$S('DDINC:"N S",1:"N") W "  ",DDP," " W:DDA1 "v " D DOT W ?DDTB1-12,"(",DDW," " S:'$D(DDLGO) DDLGO=0 W:DDCR "C " W:DDLGO "L" W ")->"
 Q
DOT F I=$L(DDP):1:DDTB1-18 W "."
 Q
EXT ;
 I DD5=DD9 S DDP="  "_$P(DDP,":",2,999),DDPT="" Q
 W "  ",$S(IOST["C":$E(DD5,1,20),1:DD5)," (#",DDPT,")",?DDTB1,"|",?DDTB2,"|",!
 S DDP="  "_$P(DD7,":",2,999),DD9=DD5,DDPT="" Q
END I $D(^UTILITY($J,"FD",DDFLE,"TO",DDLN)) D TO W:$X'>DDTB1 ?DDTB1,"|" W ?DDTB2,"|",! S DDOUT=1 D:$Y>DDMIOSL HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT),END
 I DDOUT S DDOUT=0 D VIIVA^DDMAP2 G NXF
 S DDPCK=+$O(^UTILITY($J,"FD",DDFLE)) I '$D(^DD(DDPCK,0,"UP")) D VIIVA^DDMAP2
 G NXF
 Q

DDMAP2
DDMAP2 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;2/4/91  3:38 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NXF ;Loop thru file selected and get to/from pointers
 F DDFLE=0:0 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) G:DDFLE'>0 ST D GETTO,GETFR
GETTO ;Look down "PT" X-ref to find files that point to me.
 F DDPT=0:0 S DDPT=$O(^DD(DDFLE,0,"PT",DDPT)) Q:DDPT'>0  F DDPTF=0:0 S DDPTF=$O(^DD(DDFLE,0,"PT",DDPT,DDPTF)) Q:DDPTF'>0  D NOT I DDW D NOT1
 Q
NOT1 S DDTO(DDFLE)=$S('$D(DDTO(DDFLE)):1,1:DDTO(DDFLE)+1) S ^UTILITY($J,"FD",DDFLE,"TO",DDTO(DDFLE),DDPT,DDPTF)=DDA1
 Q
NOT S DDW=0 I $D(^DD(DDPT,DDPTF,0)) S DDA1=$P(^(0),U,1,2),X=$P(DDA1,U,2) S:(X[("P"_DDFLE))!(X["V") DDW=1 Q
 Q
GETFR S DDPTF=DDFLE ;Look at all fields (and subs) to find pointers to others.
NXTF F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) G:DDPCK'>0 SUB S DDA1=$P(^DD(DDPTF,DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V"
 Q
SUB F DDMAPC=0:0 S DDPTF=$O(^DD(DDPTF)) Q:'$D(^DD(DDPTF,0,"UP"))!(DDPTF'[DDFLE)  D NXFLD
 Q
NXFLD F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) Q:DDPCK'>0  S DDA1=$P(^(DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V"
 Q
SETF S DDPT=+$P(DDA2,"P",2) S:DDPT ^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=DDA1
 Q
SETV F X=0:0 S X=$O(^DD(DDPTF,DDPCK,"V",X)) Q:X'>0  S DDPT=$P(^(X,0),U),^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=$P(DDA1,U,1)_U_"V"_DDPT
 Q
ST S DD9=0,DDFLE="",DDTB1=IOM\2,DDTB2=$S(IOM/4>30:30,1:IOM\4)+DDTB1,DDFNMAX=DDTB2-DDTB1-5,DDMIOSL=IOSL-4 D HDR G KILL^DDMAP:$D(DTOUT),^DDMAP1
VIIVA S DD5=$S($X<DDTB1:1,1:0) W:DD5 ?DDTB1,"-" W:'DD5 " " S DD5=$S(DD5:DDTB1,1:$X-1) F I=1:1:(DDTB2-DD5-1) W "-"
 W "-",! Q
HDR I "C"[$E(IOST) R !,"Enter ""^"" to exit or return to continue: ",X:$S($D(DTIME):DTIME,1:300) I X="^"!'$T S DTOUT=1 Q
 S Y=DT X ^DD("DD") W:$Y @IOF W !,"    File/Package: ",DDPCKN,?DDTB1+3,"Date: ",Y,!!
 W "  FILE (#)",?DDTB1-12,"POINTER","           (#) FILE",!,"   POINTER FIELD",?DDTB1-12," TYPE" W "           POINTER FIELD",?DDTB2+1,"FILE POINTED TO",! F I=1:1:IOM W "-"
 W !,"          L=Laygo      S=File not in set      N=Normal Ref.      C=Xref.",!,"          *=Truncated      m=Multiple           v=Variable Pointer",!!
 Q

DDPA1
DDPA1 ;SFISC/TKW  RESET IX NODES ON HAND-EDITED TEMPLATES ;5/12/95  11:23
V ;;21.0;VA FileMan;**2**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N A,B,I,J,X,DIR
 S DIR("?",1)="This will repair known hand-edited templates in national packages.",DIR("?",2)="If none show on the report, it means that none of the templates on your system"
 S DIR("?")="needed to be repaired."
 S DIR(0)="Y",DIR("A")="Repair ""IX"" nodes on hand-edited templates",DIR("B")="Yes" D ^DIR Q:Y'=1
 W !!,"Searching Sort Template file...please wait",!!,"Report of templates repaired",!!
 K ^TMP($J) S U="^"
 S ^TMP($J,"DG FEMALE INPATIENTS")="^DPT(""CN"",^DPT(^2"
 S ^TMP($J,"RT WARD LIST")="^DPT(""AA"",^DPT(^2"
 S J="RT CHARGED BY HOME BY BOR^RT CHARGED BY HOME BY NAME^RT OVER BY HOME BY BOR^RT OVER BY HOME BY NAME^RT OVER BY DIV BY BOR^RT OVER BY DIV BY NAME^RT OVER BY DIV BY TD^RT OVER BY HOME BY TD^RT CHARGED BY HOME BY TD"
 F I=1:1 S X=$P(J,U,I) Q:X=""  S ^TMP($J,X)="^RT(""AC"",^RT(^2"
 S J="RT HOME LIST BY BOR^RT HOME LIST BY NAME^RT HOME LIST BY TD"
 F I=1:1 S X=$P(J,U,I) Q:X=""  S ^TMP($J,X)="^RT(""AH"",^RT(^2"
 S ^TMP($J,"RT LOOSE FILING")="^RT(""AL"",^RT(^2"
 S ^TMP($J,"DGPT WORKFILE")="^DG(45.85,""ACENSUS"",^DG(45.85,^2"
 S ^TMP($J,"A1B2 OUTPUT1")="^A1B2(11500.2,""AREM"",^A1B2(11500.2,^2"
 S ^TMP($J,"DG PTF NO ADMISSION")="^DGPM(""ATT3"",^DGPM(^2"
 S (^TMP($J,"XTLK KEYWORD ALPHA"),^TMP($J,"XTLK KEYWORD CODES"))="^XT(8984.1,""AD"",^XT(8984.1,^2"
 F I=0:0 S I=$O(^DIBT(I)) Q:'I  S X=$P($G(^(I,0)),U) I $D(^TMP($J,X)) D
 . S B=$G(^DIBT(I,2,1,"IX")),A=^TMP($J,X) Q:A=B
 . W X,!,"  Before: ",B,!
 . S ^DIBT(I,2,1,"IX")=A
 . W "  After:  ",^DIBT(I,2,1,"IX"),!
 . Q
 K ^TMP($J) W !!!,"DONE!!",!
 Q

DDPA2
DDPA2 ;SFISC/TKW  FIND NON-CANONIC SORT RANGES WITH NO ASK NODE ;8/8/95  10:46
V ;;21.0;VA FileMan;**9**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;  This routine will find any sort templates that have a sort field
 ; with a range that is FROM or TO a non-canonic number, has no
 ; ASK node, and that has
 ; had an extra space inserted by FM21 prior to patch DI*21*9.
 N I,J,X,Y,DIR,DIERR,DTOUT,DIRUT,DIROUT,DUOUT
 W !!,"This routine will report any sort templates that have been corrupted due to",!,"a bug in FM21 that has been repaired by patch DI*21*9.",!!
 W "If any templates are reported here, you can repair them by editing the template,",!,"without changing any of the sort fields.",!
 S DIR("?",1)="This routine will report any sort templates that may have been corrupted.",DIR("?",2)="If none show on the report, it means that none of the templates on your system"
 S DIR("?")="needed to be edited."
 S DIR(0)="Y",DIR("A")="Report corrupted sort templates",DIR("B")="Yes" D ^DIR K DIR Q:Y'=1
 W !!,"Searching Sort Template file...please wait",!!,"Report of templates that need to be repaired",!!
 F I=0:0 S I=$O(^DIBT(I)) Q:'I  S X=$P($G(^(I,0)),U) D
 . S DIERR=0 F J=0:0 Q:DIERR=1  S J=$O(^DIBT(I,2,J)) Q:'J  I $P($G(^(J,0)),U,10)=4,'$G(^("ASK")),$G(^("SRTTXT"))]"" D
 .. S Y=$P($G(^DIBT(I,2,J,"F")),U,2) I Y?1." "1.E S DIERR=1 Q
 .. S Y=$P($G(^DIBT(I,2,J,"T")),U,2) I Y?1." "1.E S DIERR=1 Q
 .. Q
 . I DIERR=1 W "No. "_I_"   Name: "_X,!
 . Q
 Q

DDS
DDS ;SFISC/MLH,MKO-MAIN ROUTINE ;01:33 PM  25 Sep 1995
 ;;21.0;VA FileMan;**4,13,14**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N DIE,DX,DY,X,Y
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 ;
 D EN^DDS0(.DDSFILE,DR,.DA)
 I $G(DIERR) D:$G(DDSPARM)'["E"  G END^DDS0
 . W !,$C(7)_$$EZBLD^DIALOG(3000)
 . D MSG^DIALOG("BW")
 . S DIMSG=""
 ;
 N DR
 X:$G(^DIST(.403,+DDS,11))'?."^" ^(11)
 F  D PG Q:DDACT="Q"
 X:$G(^DIST(.403,+DDS,12))'?."^" ^(12)
 ;
 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
 G END^DDS0
 ;
PROC ;Main loop
 F  D PG Q:DDACT="Q"
 Q
 ;
PG ;Get DDSPOP and update DDSSC array
 ;If we're going to another page
 S DDACT="N"
 I '$D(DDSPGUP) D
 . S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6)
 . K:'DDSPOP DDSSC
 . I $D(DDSSEL) D
 .. S DDSDASV=DDSDA,DDSDLSV=DDSDL
 .. M DDSORGSV=DDSDAORG
 .. K DA,@$$D0(DDSDL),DDSDAORG
 .. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0
 . I '$D(DDSSC("B",DDSPG)) D
 .. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)=""
 .. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7)
 .. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK
 .. K DDSPOP
 . E  D
 .. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG
 .. N I,J,S
 .. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I)
 .. F J=I:1:DDSSC-1 D
 ... K DDSSC("B",$P(DDSSC(J+1),U),J)
 ... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)=""
 .. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)=""
 ;
 ;If we've moving up from a pop-up page
 E  K DDSPGUP
 ;
 ;Pre-action, save old and get next page
 S DDSOPB=DDSPG
 I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP"
 S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP=""
 ;
 ;Load page
 D ^DDS1(DDSPG)
 I $G(DIERR) D  Q
 . N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
 . S:P(2)="" P(2)="unnamed"
 . D BLD^DIALOG(3041,.P),ERR^DDSMSG
 . S DDACT="Q"
 ;
 ;Get DDO and DDSBK
 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
 . S DDO=+@DDSREFS@(DDSPG,"FIRST"),DDSBK=$P(^("FIRST"),",",2)
 I 'DDSBK D  Q
 . D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:""))
 . S DDACT="Q"
 ;
 ;Paint the page
 D RP^DDSR(DDSSC(DDSSC),DDSSC=1)
 ;
P1 F  D BLK Q:"^Q^NP^"[(U_DDACT_U)
 ;
 ;Post action, print any help
 D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12))
 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
 G:"^NB^N^"[(U_DDACT_U) P1
 ;
 I DDACT="Q" D
 . I '$P(DDSSC(DDSSC),U,4) D
 .. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA
 .. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3))
 .. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1
 . K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1
 Q
 ;
BLK S DDACT="N",DDSOSV=0
 ;
 I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q
 S DDSLN=@DDSREFS@(DDSPG,DDSBK)
 ;
 S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5)
 S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8)
 K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP
 ;
 I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D
 . S DDP=$P(DDSLN,U,3)
 . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) Q:'DDSDA
 . S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL")
 ;
 I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D
 . S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB")
 . S DDSDL=$L(DDSDA,",")-2
 . S (D0,DA)=+DDSDA
 ;
 I $D(DDSREP) N DDSDL,DA D
 . S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999)
 . S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA)
 . S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_","
 . S DDSDL=$L(DDSDA,",")-2
 I  N @$$D0(DDSDL) D
 . D BLDDA(DDSDA)
 . S:'DA DDO=+$P(DDSREP,U,8)
 ;
 I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG  D  Q
 . N DDSBK0
 . S DDSBK0=DDSBK
 . F  S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK))
 . Q:Y
 . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q
 . S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q
 . S DDACT="Q"
 ;
 S $P(DDSOPB,U,2)=DDSBK
 I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
 I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP"
 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D
 . S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9)
 K DDSLN
 ;
B1 D ^DDS01
 ;
 I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
 I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1
 Q
 ;
BLDDA(DDSDA) ;
 N I
 S (DA,@("D"_DDSDL))=$P(DDSDA,",")
 F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1)
 Q
 ;
D0(DL) ;Given DL, return string D0,D1,...,Dn
 N I,S
 S S="" F I=0:1:DL S S=S_"D"_I_","
 S:S?.E1"," S=$E(S,1,$L(S)-1)
 Q S
 ;
CLRMSG ;
 K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3)
 Q
 ;
PA(DDSPA) ;
 N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR
 K DDSBR X DDSPA
 I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q
 D BR^DDS2
 Q
RESET ;Programmer entry point to reset terminal and cleanup
 D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW")
 W $P($G(DDGLVID),DDGLDEL,10)
 K DDSPARM
 S DDSREFT="^TMP(""DDS"",$J)"
 D END^DDS0
 G RESET^DDGF
 ;
RUN ;Run a form
 G ^DDSRUN
CLONE ;Clone a form
 G ^DDSCLONE
PRINT ;Print a form
 G ^DDSPRNT
DFRM ;Delete a form
 G ^DDSDFRM
DBLK ;Delete unused blocks
 G ^DDSDBLK

DDS0
DDS0 ;SFISC/MLH-SETUP, CLEANUP ;8:47 AM  2 Feb 1996
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN(DDSFILE,DR,DA) ;Initial setup
 S U="^"
 D INIT^DDGLIB0() Q:$G(DIERR)
 D FORM(.DDSFILE,DR) Q:$G(DIERR)
 ;
 ;Compile the form if not already compiled
 S DDSREFS=$$REF(DDS)
 I '$$COMPILED(DDS) D EN^DDSZ(DDS) Q:$G(DIERR)
 ;
 D FRSTPG(DDS,.DA,$G(DDSPAGE)) Q:$G(DIERR)
 D REC(DDP,.DA) Q:$G(DIERR)
 D INIT
 Q
 ;
FORM(DDSFILE,DR) ;Form lookup
 ;Output:
 ;  DDS     = Form number^Form name
 ;  DDP     = File number (or 0)
 ;  DDSPG   = First page to go to on form
 ;  DIERR
 ;
 I $D(DDSFILE)[0 D BLD^DIALOG(201,"DDSFILE") Q
 ;
 N DIC,X,Y
 ;
 S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2))
 S X=$S(DR:DR,1:$P($P(DR,"[",2),"]"))
 S DIC="^DIST(.403,",DIC(0)="FNX",D="F"_DDP
 D IX^DIC K DIC
 ;
 I Y<0 D BLD^DIALOG(3021,X) Q
 I '$O(^DIST(.403,+Y,40,"B","")) D BLD^DIALOG(3022,X) Q
 S DDS=Y
 ;
 I $D(DDSFILE(1))#2 S DDP=$S(DDSFILE(1)=+DDSFILE(1):DDSFILE(1),1:+$P($G(@(DDSFILE(1)_"0)")),U,2))
 Q
 ;
FRSTPG(DDS,DA,DDSPAGE) ;Get first page of form
 ;Output:
 ;  DDSPG
 ;  DDSSEL = 1, if DA is null and there is a record selection page
 ;  DIERR
 ;
 N P
 I $G(DA)!$P(^DIST(.403,+DDS,0),U,10) D
 . S P=$S($G(DDSPAGE):DDSPAGE,1:1)
 . S DDSPG=$O(^DIST(.403,+DDS,40,"B",P,""))
 . I $D(^DIST(.403,+DDS,40,+DDSPG,0))[0 D BLD^DIALOG(3023,"number "_P)
 E  D PG^DDSRSEL D:'$G(DDSSEL) BLD^DIALOG(202,"record")
 Q
 ;
REC(DDP,DA) ;Check record and lock
 ;Output:
 ;  DIE      = Global root
 ;  DDSDA    = DA,DA(1),...,
 ;  DDSDAORG = Original DA array
 ;  DDSDL    = Level number (top=0)
 ;  DDSDLORG = Original level number
 ;  DDSFLORG  = Orig DDP^Orig DIE
 ;  D0,D1,etc.
 ;  DIERR
 ;
 I '$G(DA) D  Q
 . S DIE="",(DDSDL,DDSDLORG)=0,DDSDA="0,"
 . S DA="",DDSDAORG=DA
 ;
 D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1) Q:$G(DIERR)
 ;
 I $D(DIOVRD)[0 D  Q:$G(DIERR)
 . N DDSTOP S DDSTOP=$$FNO^DILIBF(DDP)
 . Q:$P($G(^DD(DDSTOP,0,"DI")),U,2)'["Y"
 . N P S P("FILE")=$P(@(DIE_"0)"),U)
 . D BLD^DIALOG(405,DDSTOP,.P)
 ;
 S DDSDLORG=DDSDL
 K DDSDAORG S (DDSDAORG,@("D"_DDSDL))=DA
 F DDSI=1:1:DDSDL S (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI)
 S DDSFLORG=$G(DDP)_$G(DIE)
 K DDSI
 Q
 ;
INIT ;Initialize some variables
 ; DDSHBX   = $Y of first line of help area
 ; DDSREFT  = Global reference of temporary global location
 ; DDSFDO   = 1 if entire form is display-only
 ; DDSCHG   = Change flag
 ; DDSKM    = Flag to keep whatever's in help area
 ; DDSH     = Flag to indicate help area is empty
 ; DDSSC    = Array to indicate what pages are on the screen
 ;
 S DDSHBX=IOSL-7
 S DDXY=IOXY_" S $X=DX,$Y=DY"
 ;
 K DDH,DDSSC,DDSCHANG,DDSSAVE
 S DDSH=1,(DDH,DDM,DDSCHG,DDSSC)=0,DDACT="N"
 S DDSREFT="^TMP(""DDS"",$J,"_+DDS_")"
 K @DDSREFT
 ;
 N %,%H,%I,X
 D NOW^%DTC
 S $P(^DIST(.403,+DDS,0),U,6)=$E(%,1,12)
 Q
 ;
END I $D(DDSHBX) S DX=0,DY=IOSL-1 X IOXY
 D KILL^DDGLIB0($G(DDSPARM))
 ;
 D:$D(^TMP("DDS",$J,"LOCK")) UNLOCK
 ;
 K:'$G(DA) DA
 I $D(DA),$D(DDSDAORG)#2,$D(DDSDLORG)#2 D
 . K DA,D0
 . S DA=DDSDAORG
 . F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) K @("D"_DDSI)
 ;
 K:$G(DDSPARM)'["E" DIERR,^TMP("DIERR",$J)
 K:$D(DDSREFT)#2 @DDSREFT,DDSREFT
 K ^TMP("DDSH",$J),^TMP("DDSWP",$J)
 K DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP
 K DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL
 K DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI
 K DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG
 K DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSTP,DDSU,DDSX
 K DDSHBX,DDSREFS,DDXY
 K DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX
 K A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS
 Q
 ;
UNLOCK ;Unlock any lock records
 N I
 S I="" F  S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I=""  L -@I
 K ^TMP("DDS",$J,"LOCK")
 Q
 ;
COMPILED(DDS) ;Return 1 if form is compiled
 Q $D(@$$REF(DDS))>0
 ;
REF(DDS) ;Return global reference for compiled global
 ;Q "^DIST(.403,""AZ"","_+DDS_")"
 Q "^DIST(.403,"_+DDS_",""AZ"")"
 ;
IXF ;
 N D0,DA,DIC,DP,Y S DIC="^DD("_DDGFDD_",",DIC(0)="EMN" D ^DIC
 I Y'>0 K X
 E  S X=+$P(Y,"E")
 Q

DDS01
DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;01:42 PM  25 Sep 1995
 ;;21.0;VA FileMan;**4,13,14**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F  D IN,CHK Q:"^Q^NB^NP^"[(U_DDACT_U)
 Q
 ;
IN K DDSBR,DDSFLD,DDSO,DDSU,DIR
 S:$D(@DDSREFS@(DDSPG,$S(DDO:DDSBK,1:0),DDO,"N"))#2 DDSU("N")=^("N")
 ;
 I DDM,'$G(DDSKM) D CLRMSG^DDS
 G:'DDO COM^DDSCOM
 ;
 S DDSOSV=0
 F DDSI=0,1,2,4,7,10:1:14,20 D
 . S:$D(^DIST(.404,DDSBK,40,DDO,DDSI))#2 DDSO(DDSI)=^(DDSI)
 K DDSI
 ;
 S DDSFLD=$G(DDSO(1)) K DDSO(1)
 I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,DDSFLD=DDO_","_DDSBK
 ;
 I DDSFLD]"",DDSDA]"" F DDSI="A","D","F","M","O","X" D
 . S:$D(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,DDSI))#2 DDSU(DDSI)=^(DDSI)
 K DDSI
 ;
 I '$D(DDSREP)!DDSDA,$$UNED($G(DDSU("A")),$G(DDSO(4)),$G(DDSU("N"))) D  Q
 . S:DDACT="U" DDACT="L"
 . S:DDACT="D" DDACT="R"
 . D CURSOR Q:$D(DDSBR)#2
 . S DDSCHKQ=1
 ;
 S (X,DDSOLD)=$G(DDSU("D")),DDSEXT=$G(DDSU("X"),X)
 ;
 X:$G(DDSO(11))'?."^" DDSO(11)
 I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
 ;
 S DIR0N=1 Q:DDSFLD=""
 ;
 S:$G(^DD(DDP,DDSFLD,0))'?."^" DDSU("DD")=^(0)
 I $D(DDSU("N"))[0 S DDACT="N" Q
 Q:$D(DDSO(2))[0
 ;
 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
 K DDSKM,DDQ
 ;
 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
 S:$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10) $P(DIR0,U,6)=1
 S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+$P(DDSREP,U,3)-1
 ;
 I $D(DDSREP),'DDSDA,$P(DDSO(0),U,3)'=2 K DDSU("DD") G SEL^DDSM
 I $D(DDSU("M"))#2 S DDSGL=U_$P(DDSU("M"),U,2) G:'DDSU("M") WP^DDSWP
 S DIR("B")=$G(DDSU("X"),DDSOLD)
 ;
 I $D(DDSU("M"))#2 D SEL^DDS5 G:X'=DDSOLD&(DDACT="N") EXT
 I $P($G(DDSO(0)),U,3)'=2 S DIR(0)=DDP_","_DDSFLD_"O"
 E  D DIR^DDSFO
 D ^DIR K DIR,DUOUT,DIRUT,DIROUT
 I DIR0N S (X,Y)=DDSOLD Q
 ;
EXT I $E(X)=U!$D(DTOUT) S DIR0N=1 Q
 G EXT^DDS02
 ;
CHK Q:$D(DDSBR)#2
 I $G(DDSCHKQ)=1 K DDSCHKQ Q
 G:$D(DTOUT) TO^DDS3
 G:$E(X)=U UPA^DDS2
 I $G(DDSFLD)=.01,X="",$G(DA) G ^DDS6
 ;
 I 'DIR0N,$G(DDSFLD),$D(DDSU("M"))[0,$G(DDSCHKQ)'=2,$P($G(DDSU("DD")),U,5,99)["DINUM"!($P($G(DDSU("DD")),U,2)["I")!$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P($G(DDSU("A")),U,4)) G UNED^DDS02
 K DDSCHKQ
 ;
 I $G(DDSFLD)=.01,$G(DDSPTB)]"",$G(DDSREP)<2,'DIR0N D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
 X:$G(DDSO(12))'?."^" DDSO(12)
 ;
 I 'DIR0N,DDO,$G(DDSFLD)]"" D
 . I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
 . S DDSCHG=1
 . S:+$G(DDSU("F"))'=1 $P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1
 . X:$G(DDSO(13))'?."^" DDSO(13)
 . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG)
 . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG)
 ;
 I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
 I $T(@DDACT)]"" G @DDACT
 I 'DDO G:X]"" ^DDS3 S DDSO(0)=0
 ;
 G:"^U^D^R^L^"[(U_DDACT_U) CURSOR
 G:$D(DDSU("M"))[0 NF
 G:DDSU("M") ^DDS5
 D EDIT^DDSWP,R^DDSR
 ;
NF I 'DDO,DDSOSV S DDO=DDSOSV Q
 ;
 I DDO,$S($D(DDSREP):DDSDA,1:1) D
 . D:'$D(DDSU("M"))
 .. I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDSSTACK="`"_^(DDO)
 .. E  I $P($G(DDSO(7)),U,2)]"" S DDSSTACK=$P(DDSO(7),U,2)
 . X:$G(DDSO(10))'?."^" DDSO(10)
 ;
 I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSU
 I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2
 S DDACT="N"
 ;
CURSOR N ACT,B,BLK,BLK0,FND,N,REP
 S:$D(DDSU("N"))[0 DDSU("N")=$G(@DDSREFS@(DDSPG,DDSBK,DDO,"N"))
 S FND=0
 I $D(DDSREP),DDO D MNAV^DDSM(.FND) Q:FND
 ;
 S B=U,(BLK,BLK0)=DDSBK,N=DDSU("N"),ACT=$S(DDO&$G(DDSDN):"N",1:DDACT)
 F  D  Q:FND!$D(REP)
 . S DDO=$P(N,U,$L($P("U^D^R^L^N",ACT),U))
 . I 'DDO S (DDO,DDSBK)=0,FND=1 Q
 . ;
 . S DDSBK=$P(DDO,",",2),DDO=+DDO
 . I DDSBK D  Q:$D(REP)
 .. I $P($G(@DDSREFS@(DDSPG,DDSBK)),U,4) D
 ... S DDO=$P($G(@DDSREFS@(DDSPG,DDSBK)),U,9),ACT="N"
 .. E  S ACT=DDACT
 .. I '$P($G(@DDSREFT@(DDSPG,DDSBK)),U),DDSDAORG S B=B_DDSBK_U
 .. E  I $P(@DDSREFS@(DDSPG,DDSBK),U,7)>1 S REP=1,DDACT="NB",DDSBR=""
 . E  S DDSBK=BLK
 . ;
 . I B'[(U_DDSBK_U) S FND=1 S:DDSBK'=BLK0 DDACT="NB",DDSBR=""
 . ;
 . S:'FND N=$G(@DDSREFS@(DDSPG,DDSBK,+DDO,"N")),BLK=DDSBK
 Q
 ;
NP ;;
 G:$D(DDSREP)&DDO PGDN^DDSM
 S:DDSNP]"" DDSPG=DDSNP
 S:DDSNP="" DDACT="N"
 Q
PP ;;
 G:$D(DDSREP)&DDO PGUP^DDSM
 S DDSPG=$$PP^DDS5(.Y)
 S DDACT=$S(Y=1:"NP",1:"N")
 Q
NB ;;
 S DDSBK=$$NB^DDS5(.Y),DDACT=$S(Y=1:"NB",1:"N")
 Q
SEL ;;
 I $G(DDSSEL) W $C(7) Q
 S DDACT="N" G PG^DDSRSEL
SV ;;
 G SV^DDS02
QT ;;
 G QT^DDS3
EX ;;
 G EX^DDS3
CL ;;
 G CL^DDS3
RF ;;
 G R^DDSR
 ;
UNED(ATT,DEF,N) ;
 Q $S(N="":1,$P(ATT,U,4)="":$P(DEF,U,4)=1,1:$P(ATT,U,4)=1)&'$P(N,U,11)

DDS02
DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;07:12 AM  12 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
UNED ;Change was made to uneditable field
 D MSG^DDSMSG("No editing allowed.",1)
 S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
 Q
 ;
SV ;Save
 S DDACT="N"
 I $G(DDSDN)=1,DDO D ERR3^DDS3 Q
 I DDSSC'>1,'$G(DDSSEL),'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q
 N DDSEM
 S DDSEM(1)="You cannot save changes at this level."
 S DDSEM(2)="To close the current page, press <PF1>C."
 D MSG^DDSMSG(.DDSEM,1)
 Q
 ;
EXT ;Process external form
 I '$P($G(DDSU("DD")),U,2),$P($G(DDSU("DD")),U,2)["P" D PT
 I $P($G(DDSO(0)),U,3)=2,$E($P($G(DDSO(20)),U))="P" D PTFO
 ;
 S:DDSOLD=Y DIR0N=1
 S DDSX=X,DDSY=Y
 I Y]"",$P($G(DDSU("DD")),U,2)["O",$G(^DD(DDP,DDSFLD,2))'?."^" K Y(0) X ^(2) S Y(0)=Y
 ;
 S DDSEXT=$G(Y(0,0),$G(Y(0),Y)),X=DDSY
 ;
 I $D(DDSO(14)) K DDSERROR X DDSO(14) I $D(DDSERROR)#2 D  Q
 . K DDSERROR,DDSY S DIR0("L")=DDSEXT,DDSCHKQ=1
 ;
 I DDSY="",DDSFLD'=.01 N DDSREQ D
 . S DDSREQ=$P($G(DDSO(4)),U)
 . S:$P($G(DDSU("A")),U)]"" DDSREQ=$P(DDSU("A"),U)
 . I DDSREQ="",$P($G(DDSU("DD")),U,2)["R" S DDSREQ=1
 I DDSY="",DDSFLD'=.01,DDSREQ D  K DDSY Q
 . S DIR0("L")=DDSEXT
 . D MSG^DDSMSG("This is a required field.",1)
 . S DDSCHKQ=1
 ;
 S DY=$P(DIR0,U),DX=$P(DIR0,U,2)
 I DDSEXT'=DDSX D
 . X IOXY
 . S DDSX=$E(DDSEXT,1,$P(DIR0,U,3))
 . I '$P(DIR0,U,6) S DDSX=DDSX_$J("",$P(DIR0,U,3)-$L(DDSEXT))
 . E  S DDSX=$J("",$P(DIR0,U,3)-$L(DDSEXT))_DDSX
 . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
 ;
 S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
 S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY I DDSY="",$D(DDSU("X")) S ^("X")=""
 K DDSY
 Q
 ;
PT ;Modify Y for pointer type fields
 I $P(Y,U,3)=1 D
 . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_U_$P(DDSU("DD"),U,3)
 S Y=$P(Y,U)
 Q
 ;
PTFO ;Modify Y for pointer type form only fields
 I $P(Y,U,3)=1 D
 . N R,I S R=""
 . F I=1:1 Q:$D(DA(I))[0  S R=R_DA(I)_","
 . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,@DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$S($P(DDSO(20),U,3):^DIC(+$P(DDSO(20),U,3),0,"GL"),1:U_$P($P(DDSO(20),U,3),":"))
 S Y=$S(Y=-1:"",1:$P(Y,U))
 Q

DDS1
DDS1(DDSPG) ;SFISC/MKO-LOAD PAGE ;10:03 AM  1 Aug 1995
 ;;21.0;VA FileMan;**4,13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Input:
 ;  DDS     = Form number^Form name
 ;  DDSPG   = Internal page number
 ;  DA      = Record array
 ;  DDSREFT = Global location where data (temporarily) is stored
 ;  DDP     = Primary file number of form
 ;  DIE     = Global root of form
 ;  DDSDA   = DA,DA(1),... of form
 ;  DDSDL   = Level number
 ;Also needed for pointed-to blocks:
 ;  DDSDAORG
 ;  DDSDLORG
 ;Returns:
 ;  DIERR
 ;
 S U="^"
 ;
 ;Get header block
 S DDS1B=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,2)
 I DDS1B]"" D BLK(DDSPG,DDS1B,"",1) G:$G(DIERR) END
 ;
 ;Get all other blocks on page
 S DDS1BO="" F  S DDS1BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",DDS1BO)) Q:DDS1BO=""  S DDS1B=$O(^(DDS1BO,0)) Q:'DDS1B  D BLK(DDSPG,DDS1B,DDS1BO) G:$G(DIERR) END
 ;
END K DDS1B,DDS1BO
 Q
 ;
BLK(DDSPG,DDS1B,DDS1BO,DDS1H,DDS1E) ;Load block
 ;In:  DDS1H  = 1 if a header block
 ;     DDS1E  = 1 if we're loading up a pointed-to block and
 ;              we want interactive dialog (DIC(0)["E") in the lookup
 ;
 I $D(^DIST(.404,DDS1B,0))[0 D BLD^DIALOG(3051,"#"_DDS1B) Q
 ;
 N DDS1PTB,DDS1REP S DDS1PTB=""
 I '$G(DDS1H) D
 . S DDS1PTB=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,1)),DDS1REP=$G(^(2))
 . K:DDS1REP<2 DDS1REP
 ;
 I DDS1PTB]"" N @$$D0(DDSDL),DA,DDP,DIE,DDSDL,DDSDA D  Q:$G(DIERR)
 . I $G(DDS1REP)>1 D
 .. D BK^DDS10(.DDS1B,.DDP) Q:$G(DIERR)
 .. D GDA^DDS10(DDS1B,$G(DDS1E),.DA) Q:$G(DIERR)
 .. S DDP=$G(^DD(DDP,0,"UP"))
 .. D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1)
 .. D GETD0(.DA,DDSDL)
 . E  D
 .. D SET^DDS10(DDS1B,$G(DDS1E),.DA,.DDP,.DIE,.DDSDL,.DDSDA)
 .. I +$G(DIERR)=1,$G(^TMP("DIERR",$J,1))=601 D
 ... L -@(DIE_DA_")")
 ... K ^TMP("DDS",$J,"LOCK",DIE_DA_")")
 ... D CLEAN^DILF
 ... S DA="",DDSDA=""
 .. Q:$G(DIERR)
 .. I DA="",'$G(DDS1E),$P($G(@DDSREFT@(DDSPG,DDS1B)),U)]"" S DDSDA=$P(^(DDS1B),U),DA=+DDSDA
 .. S D0=DA
 ;
 I $G(DA)!'$G(DDSDAORG),$G(@DDSREFT@(DDSPG,DDS1B,DDSDA))<1 D
 . S $P(@DDSREFT@(DDSPG,DDS1B,DDSDA),U)=1
 . I $G(DDS1REP)>1 D REP Q
 . ;
 . S @DDSREFT@(DDSPG,DDS1B,DDSDA,"GL")=DIE
 . D ^DDS11(DDS1B)
 ;
 S $P(@DDSREFT@(DDSPG,DDS1B),U)=$G(DDSDA)
 Q
 ;
REP ;Load data for repeating block
 N DDS1DDP,DDS1IND,DDS1INI,DDS1MUL,DDS1PDA,DDS1REF,DDS1RT,DDS1SEL
 N DDS1SN,DDS1VAL
 S DDS1REF=$NA(@DDSREFT@(DDSPG,DDS1B))
 S DDS1DDP=$P(@DDSREFS@(DDSPG,DDS1B),U,3)
 S DDS1IND=$P(DDS1REP,U,2) S:DDS1IND="" DDS1IND="B"
 S DDS1INI=$P(DDS1REP,U,3)
 S DDS1SEL=$P(@DDSREFS@(DDSPG,DDS1B),U,10)
 S DDS1PDA=DDSDA
 ;
 S DDS1MUL=$O(^DD(DDP,"SB",DDS1DDP,""))
 ;
 S $P(@DDS1REF@(DDS1PDA),U,7,10)=DDP_U_DDS1MUL_U_DDS1SEL_U_DDS1IND
 S @DDS1REF@(DDSDA,"GL")=$S(DDS1MUL:DIE_+DA_","""_$P($P(^DD(DDP,DDS1MUL,0),U,4),";")_""",",1:^DIC(DDS1DDP,0,"GL"))
 ;
 N DIE,DDP
 S DIE=@DDS1REF@(DDSDA,"GL"),DDS1RT=$$CREF^DILF(DIE),DDP=DDS1DDP
 S DDS1SN=0
 ;
 I DDS1MUL D
 . D DDA^DDS5(0,.DA,.DDSDL)
 . S DDSDA=","_DDSDA
 . S:'$D(@DDS1RT@(DDS1IND)) DDS1IND="!IEN"
 . I DDS1IND="!IEN" D
 .. S DA=0 F  S DA=$O(@DDS1RT@(DA)) Q:'DA  D REPLD
 . E  D
 .. S DDS1VAL=""
 .. F  S DDS1VAL=$O(@DDS1RT@(DDS1IND,DDS1VAL)) Q:DDS1VAL=""  D
 ... S DA="" F  S DA=$O(@DDS1RT@(DDS1IND,DDS1VAL,DA)) Q:DA=""  D REPLD
 ;
 E  S DDS1VAL=DA N D0,DA,DDSDA D
 . S DDSDA=",",DA=""
 . F  S DA=$O(@DDS1RT@(DDS1IND,DDS1VAL,DA)) Q:DA=""  D REPLD
 ;
 ;
 I DDS1INI="l"!(DDS1INI="n") D
 . N N,T
 . S N=DDS1INI="n"
 . S DDS1SN=$O(@DDS1REF@(DDS1PDA," "),-1)+N
 . S T=DDS1SN-DDS1REP+2-N
 . S DDS1INI=$S(T<1:1_U_DDS1SN,1:T_U_(DDS1REP-'N))_U_DDS1SN
 E  S DDS1INI="1^1^1"
 ;
 S $P(@DDS1REF@(DDS1PDA),U,2,6)=DDS1PDA_U_DDS1INI_U_+DDS1REP
 ;
 I DDS1MUL D
 . D UDA^DDS5(.DA,.DDSDL)
 . S DDSDA=$P(DDSDA,",",2,999)
 Q
 ;
REPLD ;Load data
 S DDS1SN=DDS1SN+1,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA
 S @DDS1REF@(DDS1PDA,DDS1SN)=DDSDA
 S @DDS1REF@(DDS1PDA,"B",DDSDA)=DDS1SN
 D ^DDS11(DDS1B)
 Q
 ;
D0(DL) ;Given DL, return string D0,D1,...,Dn
 N I,S
 S S="" F I=0:1:DL S S=S_"D"_I_","
 S:S?.E1"," S=$E(S,1,$L(S)-1)
 Q S
 ;
GETD0(DA,DL) ;Given DA array, set D0,D1...
 N I
 S @("D"_DL)=DA
 F I=1:1:DL-1 S @("D"_(DL-I))=DA(I)
 Q

DDS10
DDS10 ;SFISC/MKO-BLOCK SETUP ;07:45 AM  24 Feb 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
SET(DDS1B,DDS1E,DA,DDP,DIE,DL,DDSDA) ;Get values for pointed-to block
 ;In:
 ;  DDS1B   = Block number or [Block name] (by ref)
 ;  DDS1E   = 1, if we're loading a pointed-to block and we want
 ;               interactive dialog (DIC(0)["E") in the lookup
 ;  DA      = Record array
 ;Returns:
 ;  DDS1B = Block number
 ;  DDP   = File number of block
 ;  DIE   = Global root based on DDP and DA
 ;  DL    = Level number (top=0)
 ;  DDSDA = DA,DA(1),...,
 ;
 D BK(.DDS1B,.DDP) Q:$G(DIERR)
 D GDA(DDS1B,DDS1E,.DA) Q:$G(DIERR)
 D GL(DDP,.DA,.DIE,.DL,.DDSDA,1) Q:$G(DIERR)
 Q
 ;
BK(DDSBK,DDP) ;Lookup block, get file number
 ;Input:
 ;  DDSBK = Block number or [Block name] (by ref)
 ;Returns:
 ;  DDSBK = Block number
 ;  DDP   = File number
 ;  DIERR
 ;
 I DDSBK=+$P(DDSBK,"E")  D  Q
 . I $D(^DIST(.404,DDSBK,0))[0 D BLD^DIALOG(3051,"#"_DDSBK) Q
 . S DDP=+$P(^DIST(.404,DDSBK,0),U,2)
 I DDSBK?1"["1.E1"]" D  Q
 . N X,Y,DIC
 . S X=$E(DDSBK,2,$L(DDSBK)-1),DIC="^DIST(.404,",DIC(0)="FZ"
 . D ^DIC I Y<0 D BLD^DIALOG(3051,"named "_X) Q
 . S DDSBK=+Y,DDP=+$P(Y(0),U,2)
 D BLD^DIALOG(3051,"#"_DDSBK)
 Q
 ;
GDA(DDS1B,DDS1E,DA) ;Find new DA
 ;Input:
 ;  DDS1B    = Block number
 ;  DDS1E    = 1:Interactive lookup
 ;  DDSDAORG = Original DA array
 ;  DDSDLORG = Original DL
 ;  DDSPG
 ;Returns:
 ;  DA      = Record number
 ;  DIERR
 ;
 N DDSDA,DDSI,X
 ;
 ;Set DA array to its original value
 S DA=DDSDAORG
 F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI)
 D DDSDA(.DA,DDSDLORG,.DDSDA)
 ;
 ;Xecute each PTB node
 F DDSI=1:1 Q:DA=""!'$D(@DDSREFS@(DDSPG,DDS1B,"PTB",DDSI))  X ^(DDSI) S:$G(X)'>0 DA=""
 ;
 ;Kill descendants of DA
 I '$G(DIERR) S DDSI=DA K DA S DA=DDSI
 S:DA'>0!$G(DIERR) DA=""
 Q
 ;
GL(F,DA,DIE,DL,DDSDA,DDSL) ;Get global root, level, and IEN
 ;Input variables:
 ;  F    = file #
 ;  DA   = array
 ;  DDSL = flag to lock record
 ;Returns:
 ;  DIE   = global root of file (null if error)
 ;  DL    = level (top=0) (null if error)
 ;  DDSDA = IEN
 ;  DIERR = Error flag
 ;
 I '$D(^DD(F)) D BLD^DIALOG(401,F) S (DIE,DL)="" Q
 I $D(^DIC(F,0,"GL"))#2 S DIE=^("GL"),DL=0
 E  D SUBGL Q:$G(DIERR)
 ;
 I '$G(DA) S DDSDA="0," Q
 D DDSDA(.DA,DL,.DDSDA)
 ;
 N DDSP S DDSP("FILE")=F,DDSP("IEN")=DDSDA
 ;
 I $D(@(DIE_DA_",0)"))[0 D BLD^DIALOG(601,"",.DDSP)
 I $D(@(DIE_DA_",-9)")) D BLD^DIALOG(602,"",.DDSP)
 ;
 I $G(DDSL),$D(^TMP("DDS",$J,"LOCK",DIE_DA_")"))[0 D  Q:$G(DIERR)
 . L +@(DIE_DA_")"):0 E  D BLD^DIALOG(110,"",.DDSP) Q
 . S ^TMP("DDS",$J,"LOCK",DIE_DA_")")=""
 Q
 ;
SUBGL ;Get root and level for subfile
 N D,I,S,U1
 S D=F
 F DL=0:1 Q:$D(^DD(D,0,"UP"))[0  S U1=^("UP") G:'$D(^DD(U1,"SB",D)) SUBER G:$D(^DD(U1,$O(^(D,"")),0))[0 SUBER S S(DL+1)=""""_$P($P(^(0),U,4),";")_"""",D=U1
 G:$D(^DIC(D,0,"GL"))[0 SUBER S DIE=^("GL")
 F I=DL:-1:1 G:$D(DA(I))[0 SUBER S DIE=DIE_DA(I)_","_S(I)_","
 Q
 ;
SUBER ;Come here if an error is encountered in GL
 S (DIE,DL)=""
 D BLD^DIALOG(309)
 Q
 ;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
 ;Input:
 ;  DA    = Record array
 ;  DL    = Level number (top=0)
 ;Output:
 ;  DDSDA = DA,DA(1),...,
 ;
 N I
 I DA="" S DDSDA="" Q
 S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_","
 Q

DDS11
DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ;08:46 AM  24 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Input variables:
 ;  DDSBK   = Block #
 ;  DDSPG   = Page # (needed for form-only fields)
 ;  DDSREFT = Temporary global location
 ;  DDP     = File number of block
 ;  DIE     = Global root of block
 ;  DDSDA   = DA,DA(1),...
 ;  DDSNFO  = Flag means don't reload form only fields
 ;
 N X,Y
 S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA))
 ;
 S DDS1FO=0
 F  S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO  D LD
 ;
 I DDP,DDSDA S @DDS1REFD@("GL")=DIE
 ;
 K DDS1REFD,DDS1FLD,DDS1FO,DDS1LN,DDS1ND,DDS1PC,DDS1DV
 K DDS1D1,DDS1D2,DDS1D3
 Q
 ;
LD ;Load data for a field
 ;
 ;Get form only fields
 I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D  Q
 . Q:$G(DDSNFO)
 . N DDP
 . S DDP=0,DDS1FLD=DDS1FO_","_DDSBK
 . Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U)
 . S Y=""
 . I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1)))
 . S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y
 ;
 ;Get DD fields
 S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^"
 Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U)
 ;
 S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^"
 S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2)
 S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3)
 ;
 D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1"))
 ;
 I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S") D
 . Q:$D(@DDS1REFD@(DDS1FLD,"X"))
 . D:Y]"" XFORM
 . S @DDS1REFD@(DDS1FLD,"X")=Y
 ;
 I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y
 Q
 ;
L1 ;Get non-multiple field
 S DDS1LN=$G(@(DIE_"DA,DDS1ND)"))
 I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC)
 E  S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y=""
 ;
 K @DDS1REFD@(DDS1FLD,"X")
 I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1)))
 S @DDS1REFD@(DDS1FLD,"D")=Y
 Q
 ;
L2 ;Get multiple field
 S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0
 S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3)
 S DDS1DIC=DIE_DA_","""_DDS1ND_""","
 ;
 D:DDS1DV'["W"
 . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D  D L22
 .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1)
 .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y))
 . E  I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22
 . E  S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22
 . E  S (Y,@DDS1REFD@(DDS1FLD,"D"))=""
 ;
 S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
 K DDS1DIC,DDS1RN,DDS1SUB
 Q
L22 ;
 I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN
 Q
 ;
DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
 N DDS1PTR,DDS1OT
 Q:DDS1LN3=""
 I DDS1LN3'="!M" S Y=DDS1LN3
 E  I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y=""
 Q:Y=""!$G(DDS1MULT)
 ;
 K DIR
 I DDS1FLD["," D
 . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3)
 . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
 . I $E($P(DIR(0),U))="P" S DDS1PTR=1
 E  D
 . S DIR(0)=DDP_","_DDS1FLD
 . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2)
 . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P"
 S DIR("V")="",(X,DIR("B"))=Y
 D ^DIR
 ;
 I DDER S Y=""
 I Y]"" D
 . I $G(DDS1PTR) S Y=$P(Y,U)
 . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
 . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0)
 . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0))
 . S DDSCHG=1
 K DDER,DIR
 Q
 ;
L3 ;Get number field
 S (@DDS1REFD@(.001,"D"),Y)=DA
 Q
 ;
EXT(DDP,DDS1FLD,Y) ;Return external form of Y
 N DDS1DV,X
 S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3)
 I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y
 I DDS1DV'["O",Y="" Q ""
 D XFORM
 Q Y
 ;
XFORM ;
 N DDS1N
 I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q
 I DDS1DV["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) Q:'$D(^(Y,0))  S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DDS1DV=$P(^(0),U,2) G XFORM
 I DDS1DV["V",+$P(Y,"E"),$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)"))#2 S X=+$P($P(^(0),U,2),"E") Q:$D(^(+$P(Y,"E"),0))[0  S Y=$P(^(0),U) I $D(^DD(+$P(X,"E"),.01,0))#2 S DDS1DV=$P(^(0),U,2),X=$P(^(0),U,3) G XFORM
 I DDS1DV["D" X ^DD("DD")
 I DDS1DV["S" S DDS1N=$P($P(";"_X,";"_Y_":",2),";",1) S:DDS1N]"" Y=DDS1N
 Q

DDS2
DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;02:18 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
UPA ;
 I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG("No jumping allowed.",1) Q
 I X?1"^"1.E,X'="^^" D JMP Q
 I $E(X)=U,$D(DDSREP),DA D END^DDSM Q
 I $E(X)=U,DDO,$G(DDSDN)=1 D MSG^DDSMSG("No exit allowed, since navigation for the block is disabled.",1) Q
 I $E(X)=U,DDO S DDSOSV=DDO,DDO=0 Q
 I $E(X)=U,'DDO D E^DDS3 Q
 Q
 ;
JMP ;Up-arrow jump
 S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL
 K DDH,DDQ S DDH=0
 S (X,DDSX)=$$UPCASE($E(X,1,63))
 ;
 ;Find exact matches
 D:$D(@DDSREFS@("CAP",X)) CAP
 D:$D(@DDSREFT@("XCAP",DDSPG,DDSBK,X)) XCAP
 ;
 ;Find partial matches
 S:X="?" (X,DDSX)=""
 F  S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"")  D CAP
 S DDSX=X F  S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSBK,DDSX)) Q:DDSX=""!($P(DDSX,X)]"")  D XCAP
 ;
 I 'DDH D MSG^DDSMSG($P(DDS2X,U,2)_" not found.",1) G KILL
 S DDS2O=DDO
 I DDH=1 S DDO=$O(DDH(DDH,""))
 E  S DDD="J" D SC^DDSU
 ;
 S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO
 G:'DDS2B KILL
 ;
 S DDS2DA=DDSDA
 I DDS2P'=DDSPG D
 . D:'$D(@DDSREFT@(DDS2P,DDS2B)) ^DDS1(DDS2P)
 . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
 . I DDS2DA="" D
 .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
 .. S DDO=DDS2O
 . E  D
 .. D CKUNED
 .. I '$G(DDS2UNED) S DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR=""
 ;
 E  I DDS2B'=DDSBK D
 . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
 . I DDS2DA="" D
 .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
 .. S DDO=DDS2O
 . E  I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D
 .. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2))
 .. S DDO=DDS2O
 . E  D CKUNED I '$G(DDS2UNED) S DDACT="NB",DDSBK=DDS2B,DDSBR=""
 ;
 E  D CKUNED I '$G(DDS2UNED) S DDACT="N"
 ;
KILL S X=DDS2X
 K DDH,DDSI,DDSPGRP,DDSX
 K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X
 Q
 ;
CKUNED ;Check uneditable status
 N DDP,DDSFLD
 ;
 I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D
 . S DDP=0
 . S DDSFLD=+DDO_","_DDS2B
 E  D
 . S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3)
 . S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U)
 ;
 S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4)
 ;
 I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D
 . D MSG^DDSMSG($P(^DIST(.404,DDS2B,40,+DDO,0),U,2)_" is uneditable.",1)
 . S DDS2UNED=1,DDO=DDS2O
 Q
 ;
CAP ;Find all captions that match DDSX
 S DDSPGRP=""
 F  S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP=""  D
 . Q:U_DDSPGRP_U'[(U_DDSPG_U)
 . S DDS2P="" F  S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P  S DDS2B="" F  S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B  S DDS2F="" F  S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F  D FILL
 Q
 ;
XCAP ;Find all xecutable captions that match DDSX
 S DDSI=0
 F  S DDSI=$O(@DDSREFT@("XCAP",DDSPG,DDSBK,DDSX,DDSI)) Q:'DDSI  D
 . I $D(^DIST(.404,DDSBK,40,DDSI,0))#2,$P(^(0),U,3)'=1 D FILL
 Q
 ;
FILL ;Fill DDH array with possible choices
 S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
 S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")"
 S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V
 K DDS2V
 Q
 ;
BR ;Evaluate DDSBR
 N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0
 S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1
 S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2)
 S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U)
 ;
 D @$S(P1]"":"PG",B1]"":"BK",1:"FD")
 S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F
 K:E DDSBR
 Q
PG ;
 I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
 E  S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),""))
 Q:'P
 S:'B1 B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1=""
BK ;
 I B1=+$P(B1,"E") D
 . S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,""))
 E  D
 . S B=$O(^DIST(.404,"B",B1,"")) Q:B=""
 . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
 Q:'B
 S:F1="" F1=$O(^DIST(.404,B,40,"B",""))
FD ;
 Q:F1=""
 I F1="COM" S (E,F)=0 Q
 I F1=+$P(F1,"E") S X="B"
 E  S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C")
 S F=$O(^DIST(.404,B,40,X,F1,""))
 S:F E=0
 Q
 ;
UPCASE(X) ;
 ;Return X in uppercase
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;
ERR ;;Unable to jump to that field.  The block on which that field is located has no record associated with it.
 ;
ERR1 ;;Unable to jump to that field.  The block on which that field is located has navigation disabled.

DDS3
DDS3 ;SFISC/MLH-COMMAND UTILS ;02:46 PM  22 Feb 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I Y(0)]"","ECNRS"[$E(Y(0)) D @$E(Y(0))
 Q
 ;
S ;Save the form
 D ^DDS4,R^DDSR
 D:$D(DDSBR)#2 BR^DDS2
 Q
 ;
R ;Repaint all pages on current screen
 ;Called after wp, mults, and deletions
 G R^DDSR
 ;
E ;
 I DDSSC>1!'DDSCHG!$P(DDSSC(DDSSC),U,4) S DDACT="Q" Q
 S DDM=1
 K DIR S DIR(0)="YO"
 S DIR("A")=$$EZBLD^DIALOG(8075)
 D BLD^DIALOG(9037,"","","DIR(""?"")")
 S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-1)_"^0"
 D ^DIR
 K DIR,DUOUT,DIROUT,DIRUT
 ;
 I Y=0!$D(DTOUT)!$D(DUOUT) D QT Q
 I Y="" S DDACT="N" Q
 I Y=1 D EX
 Q
N ;
 S:DDSNP]"" DDSPG=DDSNP,DDACT="NP"
 Q
C ;
 S DDACT="Q"
 Q
 ;
QT ;Exit, don't save
 G:DDSSC>1!$G(DDSSEL)!$P(DDSSC(DDSSC),U,4) ERR1
 I $G(DDSDN)=1,DDO G ERR3
 S DDACT="Q" Q:'DDSCHG
 D DEL^DDS6
 S DX=0,DY=IOSL-1 X IOXY
 W $P(DDGLCLR,DDGLDEL),$S($D(DTOUT):$$EZBLD^DIALOG(8076),1:"")_$$EZBLD^DIALOG(8077) H 1
 Q
 ;
EX ;Exit, save
 G:DDSSC>1!$G(DDSSEL)!$P(DDSSC(DDSSC),U,4) ERR1
 I $G(DDSDN)=1,DDO G ERR3
 S DDACT="Q"
 D ^DDS4 I 'Y S DDACT="N" D R D:$D(DDSBR)#2 BR^DDS2
 Q
CL ;Close
 I DDSSC'>1,'$G(DDSSEL),'$P(DDSSC(DDSSC),U,4) G ERR2
 I $G(DDSDN)=1,DDO G ERR3
 G E
 ;
TO ;Time-out
 I DDO,$G(DDSDN) S DDACT="N" G CURSOR^DDS01
 I DDO S DDSOSV=DDO,DDO=0
 E  D E
 Q
 ;
ERR1 ;Print error message
 D MSG^DDSMSG("You must press <PF1>C to close this page.",1)
 S DDACT="N"
 Q
 ;
ERR2 ;
 D MSG^DDSMSG("You must press <PF1>Q or <PF1>E to leave the form.",1)
 S DDACT="N"
 Q
 ;
ERR3 ;
 D MSG^DDSMSG("Since navigation for the block is disabled, that key sequence is disabled.",1)
 S DDACT="N"
 Q
 ;
 ;#8075  Save changes before leaving form (Y/N)?
 ;#8076  Time out.
 ;#8077  Changes not saved!
 ;#9037  Enter 'Y' to save before exiting...(3 lines)

DDS4
DDS4 ;SFISC/MKO-FILE AND RELOAD ;08:31 AM  24 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D ^DDS41 Q:Y'=1
 N DA,DDO,DIE,DDP,DDSDA
 ;
 S DX=0,DY=IOSL-1 X IOXY W "Filing form"_$P(DDGLCLR,DDGLDEL)
 ;
 ;File data
 S DDS4FI="F"
 F  S DDS4FI=$O(@DDSREFT@(DDS4FI)) Q:DDS4FI'?1"F".E  D
 . S DDP=$E(DDS4FI,2,999)
 . S DDS4DA=" "
 . F  S DDS4DA=$O(@DDSREFT@(DDS4FI,DDS4DA)) Q:DDS4DA=""  D REC
 ;
 ;Reload all pages on form
 S DDS4P=0
 F  S DDS4P=$O(@DDSREFT@(DDS4P)) Q:'DDS4P  D
 . S DDS4B=0
 . F  S DDS4B=$O(@DDSREFT@(DDS4P,DDS4B)) Q:'DDS4B  D
 .. S DDP=$P(@DDSREFS@(DDS4P,DDS4B),U,3),DDSDA=" "
 .. F  S DDSDA=$O(@DDSREFT@(DDS4P,DDS4B,DDSDA)) Q:'DDSDA  D
 ... S $P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U)=1,DIE=^(DDSDA,"GL")
 ... Q:$P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U,6)>1
 ... D GDA(DDSDA)
 ... D ^DDS11(DDS4B,1)
 ;
 X:$G(^DIST(.403,+DDS,14))'?."^" ^(14)
 I '$G(DDSSAVE),$G(DDSPARM)["S" S DDSSAVE=1
 S (Y,DDSH)=1,(DDSCHG,DX)=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL)
 K @DDSREFT@("ADD")
 K DIC,DDS1B,DDS1DA,DDS4B,DDS4DA,DDS4FI,DDS4FLD,DDS4FO,DDS4P
 K DDSEXT,DDSI,DDSINT,DDSLC,DDSLN,DDSND,DDSOND,DDSOLD,DDSP,DDSPC
 K DDSW,DDSX,DV
 Q
REC ;
 G:DDS4FI="F0" FORMONLY
 ;
 S DIE=@DDSREFT@(DDS4FI,DDS4DA,"GL")
 D GDA(DDS4DA)
 S DDSOND=-1 K DDSLN
 S DDS4FLD=""
 F  S DDS4FLD=$O(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD)) Q:DDS4FLD=""  D FLD
 S:$D(DDSLN)#2 @(DIE_"DA,DDSND)")=DDSLN
 Q
FLD ;
 Q:'$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F"))  S ^("F")=""
 I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1
 S DDSINT=$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
 ;
 ;Word processing fields (quit if multiple)
 I $D(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"))#2 D:'$P(^("M"),U)  Q
 . N FR,TO
 . S FR=$NA(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D"))
 . S TO=U_$$CREF^DILF($P(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"),U,2))
 . K @TO
 . M @TO=@FR
 . K @FR,@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")
 ;
 Q:$G(^DD(DDP,DDS4FLD,0))?."^"  S DDSND=$P(^(0),U,4)
 S DDSPC=$P(DDSND,";",2) Q:"0 "[DDSPC
 S DDSND=$P(DDSND,";")
 ;
 I DDSOND'=DDSND D
 . S:$D(DDSLN)#2 @(DIE_"DA,DDSOND)")=DDSLN
 . S DDSLN=$G(@(DIE_"DA,DDSND)"))
 . S DDSOND=DDSND
 ;
 I DDSPC D
 . S DDSOLD=$P(DDSLN,U,DDSPC)
 . S $P(DDSLN,U,DDSPC)=DDSINT
 E  D
 . S DDSW=$E(DDSPC,2,999),DDSP=$P(DDSW,",",2)+1
 . S DDSOLD=$E(DDSLN,+DDSW,DDSP-1)
 . S DDSX=$E(DDSLN,DDSP,999)
 . S DDSLN=$E(DDSLN,1,DDSW-1)_$J("",DDSW-1-$L(DDSLN))_DDSINT
 . S:DDSX'?." " DDSLN=DDSLN_$J("",DDSP-DDSW-$L(DDSINT))_DDSX
 ;
 I $D(^DD(DDP,DDS4FLD,1))!($P(^(0),U,2)["a") D XR
 ;
 Q
XR ;
 N DG,DP,DDS4AUD1,DDS4AUD2,DIIX
 S DP=DDP,DDSOND=-1
 I $D(DDSLN)#2 S @(DIE_"DA,DDSND)")=DDSLN K DDSLN
 ;
 I $P(^DD(DDP,DDS4FLD,0),U,2)["a" D
 . S (DDS4AUD1,DDS4AUD2)=1
 . I $G(^DD(DDP,DDS4FLD,"AUDIT"))["e",DDSOLD="" S DDS4AUD1=0
 ;
 I DDSOLD]"" D
 . S DG=0 F  S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1  D
 .. S DIC=DIE,X=DDSOLD
 .. X:$D(^DD(DDP,DDS4FLD,1,DG,2))#2 ^(2)
 . I $G(DDS4AUD2) S DG=1,X=DDSOLD,DIIX="2^"_DDS4FLD D AUDIT^DIET
 ;
 I DDSINT]"" D
 . S DG=0 F  S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1  D
 .. S DIC=DIE,X=DDSINT
 .. X:$D(^DD(DDP,DDS4FLD,1,DG,1))#2 ^(1)
 . I $G(DDS4AUD1) S DG=1,X=DDSINT,DIIX="3^"_DDS4FLD D AUDIT^DIET
 Q
GDA(DDSDA) ;
 N I
 K DA S DA=$P(DDSDA,",")
 F I=2:1:$L(DDSDA,",")-1 S DA(I-1)=$P(DDSDA,",",I)
 Q
 ;
FORMONLY ;
 N X
 D GDA(DDS4DA)
 S DDS4FLD=""
 F  S DDS4FLD=$O(@DDSREFT@("F0",DDS4DA,DDS4FLD)) Q:DDS4FLD=""  D
 . Q:'$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"F"))
 . S DDS4FO=$P(DDS4FLD,","),DDS4B=$P(DDS4FLD,",",2)
 . S DDSOLD=$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"O")),X=$G(^("D")),DDSEXT=$G(^("X"),X)
 . X:$G(^DIST(.404,DDS4B,40,DDS4FO,23))'?."^" ^(23)
 . S ^("O")=@DDSREFT@("F0",DDS4DA,DDS4FLD,"D"),^("F")=""
 Q

DDS41
DDS41 ;SFISC/MKO-VERIFY DATA ;02:49 PM  28 Feb 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N DDO,DIERR
 K DDSERROR,DDS4DONE,DDS4ERR
 S DDS4OUT=$NA(@DDSREFT@("VALMSG")) K @DDS4OUT
 S DDS4PG=DDSPG
 ;
 ;Set DA,DIE,DDP array to its original value
 I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
 . S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
 . F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
 . S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
 ;
 D LDALL
 I $G(DIERR) D  G END
 . N P
 . S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
 . S:P(2)="" P(2)="unnamed"
 . D BLD^DIALOG(3041,.P),ERR^DDSMSG
 . S DDS4ERR=1
 ;
 D LP
 ;
 S DDSPG=DDS4PG
 I '$G(DDS4ERR) D
 . S DDS4VC=$G(^DIST(.403,+DDS,20))
 . I DDS4VC'?."^" K @DDSREFT@("MSG") X DDS4VC
 ;
 I $G(@DDSREFT@("MSG"))>0!$G(DDS4ERR) D PRNT
 ;
END S Y='$D(DDSERROR)&'$G(DDS4ERR)
 K @DDS4OUT,DDS4OUT
 K DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4PG,DDS4TP
 K DDS4VC,DDSCAP,DDSDD,DDSERROR,DDSI,DDSPID
 K DDSREQ,DIERR,DV
 Q
 ;
LDALL ;Load all pages
 S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),""))
 S Y=1
 F  D ^DDS1(DDSPG) Q:$G(DIERR)  S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y
 K DDS4PG1
 Q
 ;
LP ;Loop through all pages/blocks
 S DX=0,DY=IOSL-1 X IOXY
 W "Verifying ..."_$P(DDGLCLR,DDGLDEL)
 ;
 S DDSPG=0
 F  S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG  D
 . S DDS4B=0
 . F  S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B  D
 .. I '$D(DDS4DONE(DDS4B)),$P(@DDSREFS@(DDSPG,DDS4B),U,5)="e" D
 ... S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))
 ... D VB
 Q
 ;
VB ;Loop through all fields on block
 N DDP
 S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2)
 S DDO=0 F  S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO  D VF
 Q
 ;
VF ;Check for required fields
 Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0  S DDS4TP=$P(^(0),U,3)
 Q:DDS4TP=1  Q:DDS4TP=4
 S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
 ;
 I DDS4TP=2 N DDP D
 . S DDP=0,DDS4FLD=DDO_","_DDS4B
 . K DV
 ;
 E  D  Q:DDS4FLD'=+$P(DDS4FLD,"E")!(DDS4FLD=.01)
 . S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1))
 . S DDSDD=$G(^DD(DDP,DDS4FLD,0)),DV=$P(DDSDD,U,2)
 . S:DDSCAP="" DDSCAP=$S($G(^DD(DDP,DDS4FLD,.1))]"":^(.1),1:$P(DDSDD,U))
 ;
 S DDS4DA=" "
 F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA=""  D
 . I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q
 . N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA
 . S DDS4DA=""
 . F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA  D VR
 Q
 ;
VR ;Check that value is non-null for record
 S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U)
 S:$P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" DDSREQ=$P(^("A"),U)
 ;
 I DDSREQ'=1,$G(DV)'["R" Q
 ;
 ;Required WP fields (quit if mult)
 I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M")  Q
 . I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D"))
 . E  S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")"
 . S (DDS4VAL,DDS4I)=0
 . F  S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I  I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q
 . D:'DDS4VAL LDERR
 . K DDS4REF,DDS4I,DDS4VAL
 ;
 I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR
 Q
 ;
LDERR ;Call ^DIALOG to load error
 N P
 I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S")
 S P(1)=DDSPID,P(2)=DDSCAP,P(3)=""
 I $L(DDS4DA,",")>2 D
 . N Y,C
 . S P(3)=$P(@(@DDSREFT@(DDSPG,DDS4B,$G(DDS4PDA,DDS4DA),"GL")_+DDS4DA_",0)"),U)
 . Q:P(3)=""
 . S Y=P(3),C=$P(^DD(DDP,.01,0),U,2) D Y^DIQ S P(3)=Y
 . S P(3)="(Subrecord: "_P(3)_")"
 D BLD^DIALOG(3092,.P,"",DDS4OUT,"S")
 Q
 ;
PRNT ;
 S (DDSABT,DX,DY)=0 X IOXY
 W $P(DDGLCLR,DDGLDEL,2)
 S $X=0,$Y=0
 ;
 I $G(DDS4ERR) D
 . S DDSI=0
 . F  S DDSI=$O(@DDS4OUT@(DDSI)) Q:'DDSI!DDSABT  D
 .. D:$G(@DDS4OUT@(DDSI))]"" WLIN(^(DDSI))
 G:DDSABT PRNTEND
 ;
 I $D(@DDSREFT@("MSG")) D
 . S DDSI=0
 . F  S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI!DDSABT  D
 .. D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI))
 G:DDSABT PRNTEND
 D EOP
 ;
PRNTEND ;
 K DDSABT,DDSI,DDSJ
 K @DDSREFT@("MSG")
 Q
 ;
WLIN(DDSX) ;
 ;Write a single line, wrap at word boundaries
 S DDSWIDTH=IOM-1
 F  Q:DDSX=""!DDSABT  D
 . F DDSSP=$L(DDSX," "):-1:1 I $L($P(DDSX," ",1,DDSSP))<DDSWIDTH D  Q
 .. I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q
 .. W !,$P(DDSX," ",1,DDSSP)
 .. S DDSX=$P(DDSX," ",DDSSP+1,999)
 K DDSWIDTH
 Q
EOP ;
 N X
 S DX=0,DY=IOSL-1 X IOXY
 R "Press RETURN to continue: ",X:DTIME
 S Y=X'[U&$T
 I Y S (DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0
 Q

DDS5
DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;01:34 PM  23 Jan 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q
 I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X
 I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO)
 E  I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q
 D MULT,R^DDSR
 ;
 K DDSSTACK
 X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10)
 I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR
 D:$D(DDSBR)#2 BR^DDS2
 Q
MULT ;
 N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
 ;
 I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG
 E  D
 . S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)=""
 . S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG=""
 Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0
 N:'$P(^(0),U,6) DDSSC
 ;
 D DDA(Y,.DA,.DDSDL)
 I Y'=-1 D
 . N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
 . S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3)
 . S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_","
 . F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_","
 . K DDSI
 . S DDSSTK=1
 . D PROC^DDS
 D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
 D UDA(.DA,.DDSDL)
 Q
 ;
LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord
 ;In:  DA array, DDSDL      at subfile level
 ;     DDP, DDSDA, DDSFLD   at file level
 N DDSDIE,Y
 S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
 I $D(@(DDSDIE_"+$G(DA),0)"))[0 D
 . S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0)))
 . I DA>0 D
 .. N C
 .. S Y=$P(@(DDSDIE_DA_",0)"),U)
 .. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
 .. D Y^DIQ
 . E  S (DA,Y)=""
 E  S (DA,Y)=""
 I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA
 ;
 S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N"
 Q
 ;
SEL ;Issue the read at the Select mult prompt
 S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))
 S:$D(@(DDSGL_"0)"))[0 @(DDSGL_"0)")=U_$P(^DD(DDP,+DDSFLD,0),U,2)_U_U
 D DDA(0,.DA,.DDSDL) S DDSDA="0,"_DDSDA
 D ^DIR K DIR,DUOUT,DIRUT,DIROUT
 D UDA(.DA,.DDSDL) S DDSDA=$P(DDSDA,",",2,999)
 Q:DDACT'="N"
 ;
 I DIR0N S (X,Y)=DDSOLD Q
 I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
 E  S DIR0N=1
 S Y=$P(Y,U)
 S:X="" Y=""
 Q
 ;
DDA(Y,DA,DL) ;Push Y onto DA array
 N I
 F I=DL:-1:1 S DA(I+1)=DA(I)
 S DA(1)=DA,DL=DL+1
 S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0)
 Q
 ;
UDA(DA,DL) ;Pop DA array
 N I
 S DA=DA(1)
 F I=2:1:DL S DA(I-1)=DA(I)
 K DA(DL),@("D"_DL)
 S DL=DL-1
 Q
NP(Y) ;Returns: Next page
 ;         (Y=1 if found, 0 if not found)
 N P,P1
 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
 I P1]"" D
 . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
 . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
 Q $S(Y=1:P,1:DDSPG)
PP(Y) ;
 N P,P1
 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
 I P1]"" D
 . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
 . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
 Q $S(Y=1:P,1:DDSPG)
NB(Y) ;
 N B,BO,X
 S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
 I BO F  D  Q:B=DDSBK!Y
 . S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,""))
 . S X=$G(@DDSREFS@(DDSPG,B))
 . I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1
 Q B

DDS6
DDS6 ;SFISC/MKO-DELETIONS ;2:09 PM  9 Feb 1996
 ;;21.0;VA FileMan;**13,14,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Enter here if user deleted record from the .01 of the (sub)record
 ;(called from DDS01)
 ;In:  DDSU array, DDSOLD, DDSFLD
 D D
 I 'Y D
 . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
 . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
 E  D
 . I $D(DDSREP) D
 .. D DEL^DDSM1(DDSDA)
 . E  D K(DDSDA,DIE) I $D(DDSPTB) D
 .. S DDACT="NB"
 .. S $P(@DDSREFT@(DDSPG,DDSBK),U)=""
 .. D DB^DDSR(DDSPG,DDSBK)
 .. D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
 . E  S DDACT="Q",DA="",DDSDAORG=DA,DDSDA="0,"
 . I '$D(DDSPTB),'$P(DDSSC(DDSSC),U,4),'$D(DDSREP) D
 .. D PG^DDSRSEL
 .. I $G(DDSSEL) D
 ... D CLRDAT^DDSRSEL
 ... D R^DDSR
 ... D PUT^DDSVALF(1,1,$P(^DIST(.403,+DDS,21),U),"","","0,")
 Q
 ;
DM ;Enter here if user deleted record from the Select prompt
 ;(called from DDS5)
 ;In:  DDSU array, DDSOLD, DDSFLD
 ;
 ;Get DA and DIE for subfile level and delete
 D DDA^DDS5(DDSOLD,.DA,.DDSDL)
 D
 . N DIE,DDSDA
 . S DIE=U_$P(DDSU("M"),U,2)
 . S DDSDA=DA_"," F DDSI=1:1:DDSDL S DDSDA=DDSDA_DA(DDSI)_","
 . K DDSI
 . D D
 . D:Y K(DDSDA,DIE)
 ;
 I 'Y D
 . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
 . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
 . D UDA^DDS5(.DA,.DDSDL)
 E  D
 . D LST^DDS5(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
 . D UDA^DDS5(.DA,.DDSDL)
 Q
 ;
D ;Delete the subrecord
 ;In: DA array, DIE, DDSDL; Out: Y=1 if successful
 N DR,DDS6DA,DDSI
 D:DDM CLRMSG^DDS
 S DDM=1
 ;
 K DIR S DIR(0)="YO"
 D BLD^DIALOG(8080,$$EZBLD^DIALOG(8078+(DDSDL>0)),"","DIR(""A"")")
 D BLD^DIALOG(9038,"","","DIR(""?"")")
 ;
 S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-3)_"^0"
 D ^DIR K DIR
 D CLRMSG^DDS
 I X=""!$D(DIRUT)!'Y S Y=0 K DIRUT,DUOUT,DIROUT,DTOUT Q
 ;
 S DDS6DA=DA N D0
 F DDSI=1:1 Q:$D(DA(DDSI))[0  S DDS6DA(DDSI)=DA(DDSI) N @("D"_DDSI)
 W $P(DDGLVID,DDGLDEL,9) S X=IOM X $G(^%ZOSF("RM"))
 S DR=".01///@" D ^DIE K DI
 W $P(DDGLVID,DDGLDEL,8) S X=0 X ^%ZOSF("RM")
 ;
 ;I $D(DA) H 2 W $P(DDGLCLR,DDGLDEL,2) D R^DDSR S Y=0 Q
 I $D(DA) S:$Y>(DDSHBX+1) DDSKM=1,DDM=1 S Y=0 Q
 ;
 S Y=1,DA=DDS6DA
 I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1
 F DDSI=1:1 Q:$D(DDS6DA(DDSI))[0  S DA(DDSI)=DDS6DA(DDSI)
 Q
 ;
K(DDSIEN,DIE) ;Remove all data pertaining to the (sub)record from @DDSREFT
 ;In: DDSIEN = IENS of record being deleted
 ;    DIE    = global root
 ;
 N B,P,FN,PAT,PDA,IENS
 S PAT=".E1"""_DDSIEN_""""
 ;
 ;Loop through all pages/blocks in ^TMP
 S P=0 F  S P=$O(@DDSREFT@(P)) Q:'P  D
 . S B=0 F  S B=$O(@DDSREFT@(P,B)) Q:'B  D
 .. ;Get file number of the block
 .. S FN="F"_$P(@DDSREFS@(P,B),U,3)
 .. ;
 .. ;Loop through all records loaded for that block
 .. S IENS=" "
 .. F  S IENS=$O(@DDSREFT@(P,B,IENS)) Q:'IENS  D
 ... ;
 ... ;If the data pertains to the current or ancestor file, kill it
 ... ;Get the parent IENS (also indicates the block is repeating)
 ... S PDA=$P($G(@DDSREFT@(P,B,IENS)),U,2)
 ... ;
 ... I 'PDA,IENS?@PAT,$P(@DDSREFT@(P,B,IENS,"GL"),DIE)="" D
 .... K @DDSREFT@(P,B,IENS)
 .... K @DDSREFT@(FN,IENS)
 ... E  I PDA,@DDSREFT@(P,B,IENS,"GL")=DIE D
 .... D DELP(P,B,PDA,DDSIEN)
 .... K @DDSREFT@(FN,DDSIEN)
 Q
 ;
DELP(P,B,PDA,IENS) ;Delete subrecord from parent's list
 ;In: P    = page number
 ;    B    = block number
 ;    PDA  = parent IENS
 ;    IENS = IENS of record to remove
 N R,S
 ;
 S S=$G(@DDSREFT@(P,B,PDA,"B",IENS)) Q:'S
 K @DDSREFT@(P,B,PDA,"B",IENS)
 ;
 F S=S:1 Q:$D(@DDSREFT@(P,B,PDA,S+1))[0  D
 . S R=@DDSREFT@(P,B,PDA,S+1)
 . S @DDSREFT@(P,B,PDA,S)=R
 . S @DDSREFT@(P,B,PDA,"B",R)=S
 K @DDSREFT@(P,B,PDA,S)
 Q
 ;
DEL ;Delete (sub)records added between saves
 ;(user quit without saving)
 N DA,DIK
 S DDSI=0
 F  S DDSI=$O(@DDSREFT@("ADD",DDSI)) Q:'DDSI  D
 . K DA
 . S DA=$P(@DDSREFT@("ADD",DDSI),U),DIK=U_$P(^(DDSI),U,2)
 . F DDSX=2:1:$L(DA,",")-1 S DA(DDSX-1)=$P(DA,",",DDSX)
 . S DA=+DA
 . D ^DIK
 K DDSI,DDSX
 Q
 ;#8078  record
 ;#8079  subrecord
 ;#8080  WARNING: DELETIONS ARE DONE...
 ;#9038  Enter 'Y' to delete...

DDS7
DDS7 ;SFISC/MKO-Relational ;10:42 AM  1 Aug 1995
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
RPB(DDP,DDSFLD,DDSPG) ;Repaint pointed-to block(s) recursively
 N DDS7B
 S DDS7B=""
 F  S DDS7B=$O(@DDSREFS@("PT",DDP,DDSFLD,DDSPG,DDS7B)) Q:DDS7B=""  D
 . N DDP,DDSFLD
 . I $P($G(@DDSREFS@(DDSPG,DDS7B)),U,8) D
 .. D BLK^DDS1(DDSPG,DDS7B,"","",1)
 .. D DB^DDSR(DDSPG,DDS7B)
 . S DDP=$P($G(@DDSREFS@(DDSPG,DDS7B)),U,3)
 . D:$D(@DDSREFS@("PT",DDP))
 .. S DDSFLD=""
 .. F  S DDSFLD=$O(@DDSREFS@("PT",DDP,DDSFLD)) Q:DDSFLD=""  D
 ... D:$D(@DDSREFS@("PT",DDP,DDSFLD,DDSPG)) RPB(DDP,DDSFLD,DDSPG)
 Q
 ;
RPF(DDP,DDSPTB,DDSDA,DA) ;Repaint and update pointer field of
 ;pointer blocks because user changed the .01 value
 S DDS7V=$S($D(@DDSREFT@("F"_DDP,DDSDA,.01,"X"))#2:^("X"),1:$G(^("D")))
 S DDS7DAS=U_DA_U
 F DDS7I=$L(DDSPTB,U):-1:1 D  Q:$G(DDS7FD)'=.01
 . S DDS7PTB=$P(DDSPTB,U,DDS7I)
 . D:DDS7PTB]"" RPF1
 K DDS7B,DDS7DA,DDS7DAS,DDS7DAST,DDS7DDO,DDS7FD,DDS7FI
 K DDS7I,DDS7L,DDS7PTB,DDS7RJ,DDS7V,DDS7X
 Q
RPF1 ;
 I DDS7PTB[";J" S DDS7FD="" Q
 S DDS7PTB=$P(DDS7PTB,";")
 I $L(DDS7PTB,",")=2 S DDS7FI=+DDS7PTB,DDS7FD=$P(DDS7PTB,",",2)
 E  I $L(DDS7PTB,",")=3 S DDS7FI=0,DDS7FD=$P(DDS7PTB,",",2,3)
 E  Q
 Q:DDS7FI=""!(DDS7FD="")
 ;
 ;Repaint pointer field on current page
 S DDS7B=""
 F  S DDS7B=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B))  Q:DDS7B=""  D
 . S DDS7DDO=""
 . F  S DDS7DDO=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B,DDS7DDO)) Q:DDS7DDO=""  D
 .. Q:$G(@DDSREFS@(DDSPG,DDS7B,DDS7DDO,"D"))=""  S DY=+^("D"),DX=$P(^("D"),U,2),DDS7L=$P(^("D"),U,3),DDS7RJ=$P(^("D"),U,10)
 .. X IOXY
 .. S DDS7X=$P(DDGLVID,DDGLDEL)_$E(DDS7V,1,DDS7L)_$P(DDGLVID,DDGLDEL,10)
 .. W $S(DDS7RJ:$J(" ",DDS7L-$L(DDS7V))_DDS7X,1:DDS7X_$J(" ",DDS7L-$L(DDS7V)))
 ;
 ;Reset external form of pointer data.
 ;
 ;If the pointer field is the .01, then we may have to follow back
 ;to pointers that point to this pointer block.
 ;
 ;DDS7DAS initially contains a list of records whose .01s we changed.
 ;DDS7DAST keeps a running list of all records in the pointer block
 ;that we change.
 ;DDS7DAS is finally set to this running list, so that when we go
 ;to update the pointer to the pointer block, we know which pointers
 ;to update.
 ;
 S DDS7DAST="",DDS7DA=" "
 F  S DDS7DA=$O(@DDSREFT@("F"_DDS7FI,DDS7DA)) Q:DDS7DA'[","  I DDS7DAS[(U_$G(^(DDS7DA,DDS7FD,"D"))_U) S:DDS7V="" ^("D")="",^("F")=3 S:$D(^("X"))#2 ^("X")=DDS7V I DDS7FD=.01,DDS7DAST_U'[(U_+DDS7DA_U) S DDS7DAST=DDS7DAST_U_+DDS7DA
 S DDS7DAS=DDS7DAST_U
 Q

DDSBOX
DDSBOX(DDSUL,DDSLR) ;SFISC/MKO-DRAW A BOX ;08:17 AM  9 Apr 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D BOUNDS Q:'Y
 ;
 S DDS3L=""
 S $P(DDS3L,$P(DDGLGRA,DDGLDEL,3),$P(DDSLR,",",2)-$P(DDSUL,",",2))=""
 S DDS3M=$P(DDGLGRA,DDGLDEL,4)_$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)-1)_$P(DDGLGRA,DDGLDEL,4)
 ;
 S DY=$P(DDSUL,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY
 W $P(DDGLGRA,DDGLDEL)_$P(DDGLGRA,DDGLDEL,5)_DDS3L_$P(DDGLGRA,DDGLDEL,6)
 ;
 F DY=$P(DDSUL,","):1:$P(DDSLR,",")-2 D
 . S DX=$P(DDSUL,",",2)-1 X IOXY
 . W DDS3M
 ;
 S DY=$P(DDSLR,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY
 W $P(DDGLGRA,DDGLDEL,7)_DDS3L_$P(DDGLGRA,DDGLDEL,8)_$P(DDGLGRA,DDGLDEL,2)
 ;
 K DDS3L,DDS3M
 Q
 ;
CLEAR(DDSUL,DDSLR) ;Clear area within upper left and lower right coords
 N S
 D BOUNDS Q:'Y
 ;
 S S=$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)+1)
 S DX=$P(DDSUL,",",2)-1
 F DY=$P(DDSUL,",")-1:1:$P(DDSLR,",")-1 X IOXY W S
 Q
 ;
BOUNDS ;Make sure area is within acceptable boundaries
 N DDSV,DDSP
 S Y=1
 I $G(DDSUL)=""!($G(DDSLR))="" S Y=0 Q
 ;
 F DDSV="DDSUL","DDSLR" D
 . S:$P(@DDSV,",")>DDSHBX $P(@DDSV,",")=DDSHBX
 . S:$P(@DDSV,",",2)>(IOM-1) $P(@DDSV,",",2)=IOM-1
 . F DDSP=1,2 S:$P(@DDSV,",",DDSP)<1 $P(@DDSV,",",DDSP)=1
 ;
 I $P(DDSLR,",")-$P(DDSUL,",")<2 S Y=0 Q
 I $P(DDSLR,",",2)-$P(DDSUL,",",2)<2 S Y=0 Q
 ;
 Q

DDSCAP
DDSCAP ;SFISC/MKO-INPUT TRANSFORM FOR CAPTIONS ;02:56 PM  26 Jul 1995
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
FUNC(X) ;
 Q:$E(X)'="!"
 N E,F,Y
 S F=$E(X,2,999)
 S:$P(F,"(")?.A1.L.A F=$$UPCASE($P(F,"("))_$S(F["(":"("_$P(F,"(",2,999),1:"")
 Q:$P(F,"(")'?1U1.7UN X
 Q:$T(@$P(F,"("))="" X
 ;
 D  Q:$G(E) X
 . N X S X="S Y=$$"_F
 . N F D ^DIM
 . S:'$D(X) E=1
 ;
 S @("Y=$$"_F)
 Q Y
 ;
L() ;;Get label of field
 N F1,F2
 S X=""
 S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X
 S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X
 S X=$P($G(^DD(F2,F1,0)),U)
 Q X
 ;
T() ;;Get title of field
 N F1,F2
 S X=""
 S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X
 S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X
 S X=$G(^DD(F2,F1,.1))
 Q X
 ;
U() ;;Get unique name of field
 Q $$GET^DDSVAL(DIE,.DA,3.1)
 ;
DUP(X1,X) ;;The DUP function
 Q:$G(X1)="" ""
 N %
 S %=X,X="",$P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%)
 Q X
 ;
UPCASE(X) ;Convert X to uppercase
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDSCLONE
DDSCLONE ;SFISC/MKO-CLONE A FORM ;10:20 PM  10 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
 K ^TMP("DDSCLONE",$J)
 S DDSQUIT=0,DIOVRD=1
 ;
 S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
 ;
 D GETBLKS
 D REPORT G:DDSQUIT QUIT
 D RENMSP G:DDSQUIT QUIT
 D RENAME G:DDSQUIT QUIT
 D ^DDSCLONF
 W !!!,"DONE!"
 ;
QUIT ;Cleanup
 K ^TMP("DDSCLONE",$J)
 K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
 Q
 ;
FORM() ;Prompt for form
 ;Select file
 N D,DIC
 S DDS1="CLONE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
 I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
 S DDSFILE=Y
 ;
 ;Select form
 W ! K DIC
 S DIC="^DIST(.403,",DIC(0)="QEAM"
 S DIC(0)="QEA",D="F"_+DDSFILE
 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
 S DIC("A")="Select FORM to clone: "
 S DIC("W")=$P($T(DICW),";",3,999)
DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
 D IX^DIC
 ;
FORMQ Q Y
 ;
GETBLKS ;Get all blocks on form
 ; ^TMP("DDSCLONE",$J,bk#)=Block name
 ;
 N B,P
 S P=0 F  S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P  D
 . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
 . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
 . S B=0
 . F  S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B  D
 .. Q:$D(^TMP("DDSCLONE",$J,B))
 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
 Q
 ;
REPORT ;Print report
 N B
 W !!!
 I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
 ;
 W "  BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
 W !!,"  Internal"
 W !,"  Entry Number   Block Name"
 W !,"  ------------   ----------"
 ;
 S B="" F  S B=$O(^TMP("DDSCLONE",$J,B)) Q:B=""  D
 . W !,"  "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
 ;
 K DIR
 S DIR(0)="E"
 W ! D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1
 W !
 Q
 ;
RENMSP ;Prompt for new namespace
 W !!,"The new form and blocks must be given unique names.",!
 ;
 K DIR
 S DIR(0)="Y",DIR("B")="YES"
 S DIR("A",1)="Give the new form and blocks the same names as the original,"
 S DIR("A")="but a different namespace"
 S DIR("?",1)="   Answer 'YES' if the original form and blocks are namespaced, and you want"
 S DIR("?")="   the new forms and blocks to have a different namespace."
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 I 'Y K DDSONSP,DDSNNSP Q
 ;
 K DIR
 W !!
 S DIR(0)="FA^1:30"
 S DIR("A")="Original namespace: "
 S DIR("?")="   Enter the namespace of the original form and blocks"
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 S DDSONS=Y
 ;
 K DIR,X,Y
 S DIR(0)="FA^1:30"
 S DIR("A")="     New namespace: "
 S DIR("?")="   Enter the namespace of the new form and blocks"
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 S DDSNNS=Y
 K X,Y
 Q
 ;
RENAME ;Prompt for new names
 N DDSBK,DDSBKDA
 D:'$D(IOST) HOME^%ZIS
 W @IOF
 W "Enter names for the new form and blocks."
 ;
 D RENFORM Q:DDSQUIT
 ;
 W !
 S DDSBKDA=0
 F  S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA))  Q:'DDSBKDA!DDSQUIT  D
 . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
 . D RENBLK(.DDSBK) Q:DDSQUIT
 . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
 . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
 ;
 Q
 ;
RENFORM ;Rename the form
 N DDSANS,DDSCOD
 F  D  Q:DDSANS]""!DDSQUIT
 . W !!,"Original form name: "_$P(DDSFORM,U,2)
 . W !,"     New form name: "
 . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSFORM,U,2),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
 . ;
 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
 . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
 . Q:DDSANS=""
 . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
 . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
 . I $D(^DIST(.403,"B",DDSANS)) D  Q
 .. S DDSANS=""
 .. W !!,$C(7)_"  Form with this name already exists."
 Q:DDSQUIT
 ;
 S $P(DDSFORM,U,3)=DDSANS
 Q
 ;
RENBLK(DDSBK) ;Rename the blocks
 N DDSANS,DDSCOD
 F  D  Q:DDSANS]""!DDSQUIT
 . W !!,"Original block name: "_$P(DDSBK,U)
 . W !,"     New block name: "
 . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
 . ;
 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
 . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
 . Q:DDSANS=""
 . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
 . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
 . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
 .. S DDSANS=""
 .. W !!,$C(7)_"  Block with this name already exists."
 Q:DDSQUIT
 ;
 S $P(DDSBK,U,2)=DDSANS
 Q
 ;
NAME(NAME,ONS,NNS) ;Replace old namespace with new
 I $G(ONS)=""!($G(NNS)="") Q NAME
 I $P(NAME,ONS)]"" Q NAME
 Q NNS_$E(NAME,$L(ONS)+1,999)

DDSCLONF
DDSCLONF ;SFISC/MKO-CLONE A FORM ;01:47 PM  29 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D ASKCONT Q:DDSQUIT
 D CREATBK Q:DDSQUIT
 D CREATFM Q:DDSQUIT
 D EDITFM
 D INDEXFM
 K DDSNFRM
 Q
 ;
CREATBK ;Create blocks
 N DA,DIC
 W !!,"Creating new blocks ...",!
 S DDSBKDA=0
 F  S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT  D
 . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
 . W !?2,$P(DDSBK,U,2)
 . K DIC
 . S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2)
 . D FILE^DICN K DIC
 . I Y=-1 D  Q
 .. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed."
 .. S DDSQUIT=1
 . M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA)
 . S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2)
 . W ?35,"#"_+Y
 . S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y
 Q
 ;
CREATFM ;Create form
 N DA,DIC,DDSI,DDSJ
 W !!,"Creating new form ..."
 W !?2,$P(DDSFORM,U,3)
 K DIC
 S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3)
 D FILE^DICN K DIC
 I Y=-1 D  Q
 . W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed."
 . S DDSQUIT=1
 M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM)
 ;
 ;Kill page and block multiple indexes
 S DDSJ=" " F  S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ=""  D
 . K ^DIST(.403,+Y,40,DDSJ)
 S DDSI=0 F  S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI  D
 . S DDSJ=" "
 . F  S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ=""  D
 .. K ^DIST(.403,+Y,40,DDSI,40,DDSJ)
 K ^DIST(.403,+Y,"AZ")
 ;
 S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3)
 W ?35,"#"_+Y
 S DDSNFRM=+Y
 Q
 ;
EDITFM ;Edit blocks used on new form
 W !!,"Repointing to new blocks ..."
 N DDSBK,DDSNBK,DDSPG
 S DDSPG=0 F  S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG  D
 . S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2)
 . I DDSBK]"" D
 .. N DIE,DA,DR
 .. S DIE="^DIST(.403,"_DDSNFRM_",40,"
 .. S DA(1)=DDSNFRM,DA=DDSPG
 .. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3)
 .. D ^DIE
 . ;
 . N DA,DIK
 . S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40,"
 . S DA(2)=DDSNFRM,DA(1)=DDSPG
 . S DDSBK=0
 . F  S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK  D
 .. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0  S DDSNBK=$P(^(DDSBK),U,3)
 .. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)
 .. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK
 .. S DA=DDSBK
 .. D ^DIK
 Q
 ;
INDEXFM ;Index new form
 W !,"Reindexing new form ..."
 N DIK,DA
 S DIK="^DIST(.403,",DA=DDSNFRM
 D IX1^DIK
 ;
 D EN^DDSZ(DDSNFRM)
 Q
 ;
ASKCONT ;Final chance to abort
 K DIR S DIR(0)="Y"
 S DIR("A",1)=""
 S DIR("A")="Ready to clone form"
 S DIR("?")="  Enter 'Y' to clone form.  Enter 'N' to exit."
 D ^DIR K DIR
 S:$D(DIRUT)!'Y DDSQUIT=1
 Q

DDSCOM
DDSCOM ;SFISC/MLH-COMMAND UTILS ;10:09 AM  29 Jun 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
COM ;Command line prompt
 D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG()
 K DTOUT
 I DDSSC>1!$G(DDSSEL)!$P(DDSSC(DDSSC),U,4) D
 . S DIR(0)="SO^c:CLOSE;r:REFRESH;"
 . S DIR("?",1)="Close     Refresh"
 . S DIR("B")="Close"
 E  D
 . S DIR(0)="SO^e:EXIT"_$S($D(DDSFDO)[0:";s:SAVE",1:"")_$S(DDSNP]"":";n:NEXT PAGE",1:"")_";r:REFRESH;"
 . S DIR("?",1)="Exit     "_$S($D(DDSFDO)[0:"Save     ",1:"")_$S(DDSNP]"":"Next Page     ",1:"")_"Refresh"
 S DIR("A")="COMMAND:",DIR("?",2)=" ",DIR("?")="Enter a command or '^' followed by a caption to jump to a specific field."
 S DIR("??")="^D CHLP^DDSCOM"
 D:'$G(DDSKM)
 . K DDH,DDQ
 . S DDH=3
 . S DDH(1,"T")=DIR("?",1),DDH(2,"T")=DIR("?",2),DDH(3,"T")=DIR("?")
 . D SC^DDSU
 S DDM=1 K DDSKM
 S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^30^"_(IOSL-1)_"^0"
 D ^DIR K DIR,DUOUT,DIROUT,DIRUT
 D:X="Close"
 . S:DDACT="N" Y="c"
 . S Y(0)="CLOSE"
 . S:DDACT'="N" (X,Y,Y(0))=""
 Q
CHLP ;
 K DDH,DDQ
 S DDH=0,DDS3CD=$P(DIR(0),U,2)
 F DDS3PC=1:1:$L(DDS3CD,";") D
 . S DDS3C=$C($A($P($P(DDS3CD,";",DDS3PC),":"))-32)
 . I "^E^C^S^N^R^"[(U_DDS3C_U) D
 .. S DDH=DDH+1
 .. S DDH(DDH,"T")=$P($T(@("H"_DDS3C)),";",3,999)
 D:DDH>0 SC^DDSU
 K DDS3C,DDS3CD,DDS3PC
 Q
HE ;;Exit       - Exit the form.
HC ;;Close      - Close the window and return to the previous level.
HS ;;Save       - Save all changes made during the edit session.
HN ;;Next Page  - Go to the next page.
HR ;;Refresh    - Repaint the screen.

DDSCOMP
DDSCOMP ;SFISC/MKO-EVALUATE COMPUTED EXPRESSIONS ;8:01 AM  15 Mar 1996
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PARSE(DDP,EXP,BK,NEXP,AR,FDL) ;Parse the computed expression EXP
 ;Returns:
 ;  NEXP = EXP with {expr} replaced with DDSE(n)
 ;  AR   = array when executed sets DDSE(n)
 ;  FDL  = list of fields referenced
 N I,J,N,ST
 ;
 S NEXP="",(N,AR)=0,ST=1
 S I=0 F  D  Q:'I!$G(DIERR)
 . S I=$$FIND^DDSLIB(EXP,"{",I) Q:'I
 . S N=N+1
 . S NEXP=NEXP_$E(EXP,ST,I-2)_"DDSE("_N_")"
 . S ST=$$FIND^DDSLIB(EXP,"}",I)
 . D EVAL(DDP,$E(EXP,I,ST-2),BK,N,.AR,.FDL) Q:$G(DIERR)
 . S I=ST
 Q:$G(DIERR)
 S NEXP=$S(EXP?1"=".E:"S Y",1:"")_NEXP_$E(EXP,ST,999)
 ;
 S AR=N
 S:$G(FDL)]"" FDL=$E(FDL,1,$L(FDL)-1)
 Q
 ;
EVAL(DDP,EXP,BK,N,AR,FDL) ;Evaluate field expression
 ;In:
 ;  EXP = computed expr
 ;  N   = expr number -- index into DDSE()
 ;Out:
 ;  AR  = array of code that sets DDSE(n)
 ;  FDL = list of fields used in expr
 ;
 N CD
 D:EXP?1"FO(".E FO^DDSPTR(DDP,EXP,"","",BK,.CD,.FDL,1)
 D:EXP'?1"FO(".E DD^DDSPTR(DDP,EXP,"",.CD,.FDL,1)
 Q:$G(DIERR)
 ;
 I CD=1 S AR(N)="N X "_CD(1)_",DDSE("_N_")=X"
 E  D
 . F CD=1:1:CD S AR(N,CD)=CD(CD)
 . S AR(N,CD)=AR(N,CD)_",DDSE("_N_")=X"
 . S AR(N)="N DDSI,X S DDSE("_N_")="""" F DDSI=1:1:"_CD_" Q:DDSI>1&($G(X)'>0)!'$D(*DDSREFC*,DDSI))  X ^(DDSI)"
 Q
 ;
RPCF(DDSPG) ;Repaint computed fields
 ;Called from ^DDS01 and ^DDSVALF when value used in
 ;computed expression changes
 N DDSCBK,DDSCDDO
 ;
 S DDSCBK="" F  S DDSCBK=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK)) Q:DDSCBK=""  D
 . I $P($G(@DDSREFS@(DDSPG,DDSCBK)),U,7)>1 D DB^DDSR(DDSPG,DDSCBK) Q
 . N DA,DDSDA
 . D GETDA(DDSPG,DDSCBK,.DA)
 . S DDSDA=$$DDSDA(.DA)
 . S DDSCDDO="" F  S DDSCDDO=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK,DDSCDDO)) Q:DDSCDDO=""  D RPCF1
 ;
 Q
 ;
RPCF1 ;
 N DDSC,DDSE,DDSLEN,DDSX
 S DDSC=$G(@DDSREFS@(DDSPG,DDSCBK,DDSCDDO,"D")) Q:DDSC=""
 S DDSX=$$VAL(DDSCDDO,DDSCBK,DDSDA)
 ;
 S DY=+DDSC,DX=$P(DDSC,U,2),DDSLEN=$P(DDSC,U,3)
 I $P(DDSC,U,10) S DDSX=$J("",DDSLEN-$L(DDSX))_$E(DDSX,1,DDSLEN)
 E  S DDSX=$E(DDSX,1,DDSLEN)_$J("",DDSLEN-$L(DDSX))
 X IOXY
 W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
 ;
 N DDP,DDSFLD
 S DDP=0,DDSFLD=DDSCDDO_","_DDSBK
 D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF(DDSPG)
 ;
 Q
 ;
GETDA(P,B,DA) ;Get DA array of block
 K DA
 S DA=$G(@DDSREFT@(P,B)) Q:DA=""  Q:'$G(^(B,DA))
 F I=2:1:$L(DA,",")-1 S DA(I-1)=$P(DA,",",I)
 S DA=+DA
 Q
 ;
VAL(DDSDDO,DDSBK,DDSDA) ;Return value of computed field
 N DDSE,DDSX,Y
 I $D(DDSDA) N DA D DA(DDSDA,.DA)
 S DDSX=0 F  S DDSX=$O(@DDSREFS@("COMPE",DDSBK,DDSDDO,DDSX)) Q:DDSX=""  X ^(DDSX)
 K Y X $G(@DDSREFS@("COMPE",DDSBK,DDSDDO))
 Q $G(Y)
 ;
DA(DDSDA,DA) ;Return DA array based on DDSDA
 N I
 S DA=$P(DDSDA,",")
 F I=2:1:$L(DDSDA,",") S DA(I-1)=$P(DDSDA,",",I)
 Q
 ;
DDSDA(DA) ;Return DDSDA based on DA array
 N DDSDA,I
 I $G(DA)="" S DDSDA="0,"
 E  D
 . S DDSDA=DA_","
 . F I=1:1 Q:$G(DA(I))=""  S DDSDA=DDSDA_DA(I)_","
 Q DDSDA

DDSDBLK
DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;09:15 AM  18 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 N %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y
 D INIT
 S DDSFILE=$$FILE G:DDSFILE=-1 QUIT
 D SUB(+DDSFILE,DDSSUB),FINDB(DDSSUB,DDSBLK),PROC,QUIT
 Q
 ;
ALL ;Purge all unused blocks regardless of file
 N %,DIC,DIOVRD,X,Y
 K DDSFILE
 D INIT,FINDALL(DDSBLK),PROC,QUIT
 Q
 ;
PROC ;Delete blocks in @DDSBLK
 I '$D(@DDSBLK) D  Q
 . W !!!,"There are no unused blocks associated with this file."
 ;
 D REPORT
 D ASKDEL Q:DDSQUIT
 D ASKCONT Q:DDSQUIT
 ;
 ;Delete blocks
 D:$G(DDSDEL) DELNPR
 D:'$G(DDSDEL) DELPR
 W !!,"DONE!"
 Q
 ;
INIT ;Initialize variables
 S (DDSDEL,DDSQUIT)=0,DIOVRD=1
 S DDSBLK=$NA(^TMP("DDSDBLK",$J,"BLK"))
 S DDSSUB=$NA(^TMP("DDSDBLK",$J,"SUB"))
 K @DDSBLK,@DDSSUB
 Q
 ;
QUIT ;Cleanup
 K @DDSBLK,@DDSSUB
 K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB
 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
 Q
 ;
FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file
 N B,B0,N
 S B=0 F  S B=$O(^DIST(.404,B)) Q:'B  S B0=$G(^(B,0)) D
 . S N=$P(B0,U,2)
 . I N,$D(@DDSSUB@(N)),'$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) S @DDSBLK@(B)=$P(B0,U)
 Q
 ;
FINDALL(DDSBLK) ;Find all unused blocks
 N B,B0
 S B=0 F  S B=$O(^DIST(.404,B)) Q:'B  S B0=$G(^(B,0)) D
 . I '$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) D
 .. S @DDSBLK@(B)=$P(B0,U)
 Q
 ;
FILE() ;Prompt for form
 ;Select file
 N DIC,Y
 S DDS1="PURGE UNUSED BLOCKS FROM" D W^DICRW K DDS1 G:Y<0 FILEQ
 S:'$D(@(DIC_"0)")) Y=-1
FILEQ Q Y
 ;
DELPR ;Delete blocks with prompting
 N DDSB
 W ! K DIK,DIR,DIRUT
 S DIR(0)="YA",DIR("B")="NO"
 S DIR("?")="  Enter 'Y' to delete, 'N' to keep."
 S DIK="^DIST(.404,"
 ;
 S DDSB=""
 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT  D
 . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
 . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
 . S DA=DDSB D ^DIK
 K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
 Q
 ;
DELNPR ;Delete blocks without prompting
 N DDSB
 W ! K DIK
 S DIK="^DIST(.404,"
 S DDSB=""
 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D
 . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
 . S DA=DDSB D ^DIK
 K DIK,DA
 Q
 ;
ASKDEL ;Ask if user wants to delete all unused blocks w/o confirmation
 W ! S DIR(0)="YA",DIR("B")="NO"
 S DIR("A",1)=""
 S DIR("A")="Delete all unused blocks without prompting (Y/N)? "
 S DIR("?",1)="  Enter 'Y' to delete unused blocks from the BLOCK file"
 S DIR("?",2)="    without confirmation."
 S DIR("?",3)=""
 S DIR("?")="  Enter 'N' to confirm each delete."
 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
 S DDSDEL=Y
 Q
 ;
ASKCONT ;Final chance to abort
 K DIR S DIR(0)="YA",DIR("B")="NO"
 S DIR("A",1)=""
 S DIR("A")="Continue (Y/N)? "
 S DIR("?")="  Enter 'Y' to delete form.  Enter 'N' to exit."
 D ^DIR K DIR
 S:$D(DIRUT)!'Y DDSQUIT=1
 Q
 ;
REPORT ;Print report
 N B
 W !!!
 W "  UNUSED BLOCKS"
 W:$D(DDSFILE) " ASSOCIATED WITH FILE "_$P(DDSFILE,U,2)_" (#"_$P(DDSFILE,U)_")"
 W !!,"  Internal"
 W !,"  Entry Number   Block Name"
 W !,"  ------------   ----------"
 ;
 S B="" F  S B=$O(@DDSBLK@(B)) Q:B=""  W !,"  "_B,?17,@DDSBLK@(B)
 Q
 ;
SUB(FN,OUT) ;
 ;Set OUT array for file number FN and all its subfiles
 N SUB
 I $D(^DD(FN)) S @OUT@(FN)=""
 S SUB="" F  S SUB=$O(^DD(FN,"SB",SUB)) Q:SUB=""  D SUB(SUB,OUT)
 Q

DDSDEL
DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;07:36 AM  2 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
FORM(DDSFILE,DDSECHO) ;
 ;Delete all forms/blocks associated with file DDSFILE
 N %,DIK,DIOVRD,DA,D0,X,Y
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 S DIOVRD=1
 D SETUP,GETFORMS(DDSFILE,DDSREF)
 ;
 ;Delete forms
 W:DDSECHO !?3,"Deleting the FORMS..."
 S DDSFRM="",DIK="^DIST(.403,"
 F  S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM  S DA=DDSFRM D ^DIK
 K DIK,DA
 ;
 ;Delete blocks
 W:DDSECHO !?3,"Deleting the BLOCKS..."
 S DDSBLK="",DIK="^DIST(.404,"
 F  S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK  D
 . S DDSLN=@DDSREF@("BLK",DDSBLK)
 . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3)
 . ;
 . I DDSOFRM,DDSPDD D
 .. I DDSECHO D
 ... W !!?3,$C(7)_"***  Warning  ***"
 ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")"
 ... W !?3,"was deleted from the Block file."
 ... W !!?3,"I'm deleting pointers to that block from"
 .. S DDSFRM=""
 .. F  S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM  D
 ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..."
 ... D DELBLK(DDSBLK,DDSFRM)
 .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",!
 . ;
 . E  I 'DDSOFRM D
 .. S DA=DDSBLK D ^DIK
 ;
QUIT ;Cleanup and quit
 K @DDSREF,DDSREF
 K DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG
 Q
 ;
SETUP ;Setup local variables
 S:$D(DDSECHO)[0 DDSECHO=0
 S DDSREF="^TMP(""DDSDEL"","_$J_")"
 K @DDSREF
 Q
 ;
GETFORMS(FILE,REF) ;
 ;Get all forms and blocks associated with file number FILE
 ;and all subfiles associated with FILE
 ;Put results in
 ;  @REF@("DD",file#)         = null
 ;       ("FRM",form#)        = form name
 ;       ("BLK",block#)       = block name^used on forms not being
 ;                              deleted^dd of block is being deleted
 ;       ("BLK",block#,form#) = null for all blocks that are found
 ;                              on a form not being deleted
 ;
 N B,F,P,FNAM
 ;Get DDs of file and subfiles
 D DD(FILE,REF)
 ;
 ;Get all forms associated with file
 S FNAM="" F  S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM=""  D
 . S F="" F  S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F=""  D
 .. Q:$D(^DIST(.403,F,0))[0
 .. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U)
 ;
 ;Get all blocks associated with each form
 S F="" F  S F=$O(@REF@("FRM",F)) Q:F=""  D
 . S P=0 F  S P=$O(^DIST(.403,F,40,P)) Q:'P  D
 .. S B=$P($G(^DIST(.403,F,40,P,0)),U,2)
 .. I B D SETBLK(B,REF)
 .. S B=0 F  S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B  D SETBLK(B,REF)
 Q
 ;
SETBLK(B,REF) ;
 ;Put block info into @REF
 N B0
 S B0=$G(^DIST(.404,B,0)) Q:B0?."^"
 S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2)
 Q
 ;
DELBLK(DDSBLK,DDSFRM) ;
 ;Delete block DDSBLK from form DDSFRM
 N DIK,DA,D0
 S DDSPG=0 F  S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG  D
 . I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D
 .. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40,"
 .. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK
 .. D ^DIK
 Q
 ;
DD(F,REF,K) ;
 ;Put file # and all its subfile #s into array @REF@("DD")
 ;Kill REF first if $G(K)=""
 N SB
 K:$G(K)="" @REF@("DD")
 S @REF@("DD",F)=""
 S SB="" F  S SB=$O(^DD(F,"SB",SB)) Q:SB=""  D DD(SB,REF,1)
 Q
 ;
OTHER(B,REF) ;
 ;Is block B found on forms other than what's in @REF@("FRM",F)=""
 ;If so, put form numbers in @REF@("BLK",B,F)
 N F,O,C
 S O=0,F=""
 F C="AB","AC" F  S F=$O(^DIST(.403,C,B,F)) Q:F=""  D
 . I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)=""
 Q O

DDSDFRM
DDSDFRM ;SFISC/MKO-DELETE A FORM ;09:12 AM  18 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 N %,DIC,DIOVRD,X,Y
 D INIT
 S (DDSDEL,DDSQUIT)=0
 ;
 S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
 ;
 D GETBLKS
 D REPORT
 I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT
 D ASKCONT G:DDSQUIT QUIT
 ;
 ;Delete form
 W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..."
 S DIK="^DIST(.403,",DA=+DDSFORM
 D ^DIK K DIK,DA
 ;
 ;Delete blocks
 I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR
 W !!,"DONE!"
 D QUIT
 Q
 ;
EN(DDSFORM) ;Delete form number DDSFORM
 N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 D INIT
 D GETBLKS
 ;
 ;Delete form
 S DIK="^DIST(.403,",DA=+DDSFORM
 D ^DIK K DIK,DA
 ;
 ;Delete blocks
 S DIK="^DIST(.404,"
 S DDSB="" F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D
 . Q:$P(@DDSBLK@(DDSB),U,2)
 . S DA=DDSB D ^DIK
 ;
 K @DDSBLK
 Q
 ;
INIT ;Setup
 S DIOVRD=1
 S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK"))
 K @DDSBLK
 Q
 ;
QUIT ;Cleanup
 K @DDSBLK
 K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT
 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
 Q
 ;
FORM() ;Prompt for form
 ;Select file
 N D,DIC
 S DDS1="DELETE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
 I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
 S DDSFILE=Y
 ;
 ;Select form
 W ! K DIC
 S DIC="^DIST(.403,",DIC(0)="QEAM"
 S DIC(0)="QEA",D="F"_+DDSFILE
 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
 S DIC("A")="Select FORM to delete: "
 S DIC("W")=$P($T(DICW),";",3,999)
DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
 D IX^DIC
 ;
FORMQ Q Y
 ;
GETBLKS ;Get all blocks on form
 ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms)
 ;
 N P,B
 S P=0 F  S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P  D
 . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
 . I B]"",'$D(@DDSBLK@(B)) D
 .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
 . S B=0
 . F  S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B  D:'$D(@DDSBLK@(B))
 .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM)
 Q
 ;
DELPR ;Delete blocks with prompting
 N DDSB
 W ! K DIK,DIR,DIRUT
 S DIR(0)="YA",DIR("B")="NO"
 S DIR("?")="  Enter 'Y' to delete, 'N' to keep."
 S DIK="^DIST(.404,"
 ;
 S DDSB=""
 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT  D
 . Q:$P(@DDSBLK@(DDSB),U,2)
 . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? "
 . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y
 . S DA=DDSB D ^DIK
 K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT
 Q
 ;
DELNPR ;Delete blocks without prompting
 N DDSB
 W ! K DIK
 S DIK="^DIST(.404,"
 S DDSB=""
 F  S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""  D
 . Q:$P(@DDSBLK@(DDSB),U,2)
 . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..."
 . S DA=DDSB D ^DIK
 K DIK,DA
 Q
 ;
ASKDEL ;Ask if user wants to delete all the blocks on this form
 K DIR W ! S DIR(0)="YA",DIR("B")="YES"
 S DIR("A",1)=""
 S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2)
 S DIR("A")="from the BLOCK file (Y/N)? "
 S DIR("?",1)="  Enter 'Y' to delete blocks used on form"
 S DIR("?",2)="    "_$P(DDSFORM,U,2)_" from the BLOCK file."
 S DIR("?",3)="    (Only blocks not used on other forms can be deleted.)"
 S DIR("?",4)=""
 S DIR("?")="  Enter 'N' to delete the form but not the blocks."
 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
 S DDSDEL=Y Q:'DDSDEL
 ;
 ;Ask if user wants to delete without prompting
 W ! S DIR(0)="YA",DIR("B")="NO"
 S DIR("A",1)=""
 S DIR("A")="Delete blocks without prompting (Y/N)? "
 S DIR("?",1)="  Enter 'Y' to delete blocks from the BLOCK file"
 S DIR("?",2)="    without confirmation."
 S DIR("?",3)=""
 S DIR("?")="  Enter 'N' to confirm each delete."
 D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q
 S DDSDEL(1)=Y
 Q
 ;
ASKCONT ;Final chance to abort
 K DIR S DIR(0)="YA",DIR("B")="NO"
 S DIR("A",1)=""
 S DIR("A")="Continue (Y/N)? "
 S DIR("?")="  Enter 'Y' to delete form.  Enter 'N' to exit."
 D ^DIR K DIR
 S:$D(DIRUT)!'Y DDSQUIT=1
 Q
 ;
REPORT ;Print report
 N B
 W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q
 W "  BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
 W !!,"  Internal",?50,"Used on"
 W !,"  Entry Number   Block Name",?50,"Other Forms?   Deletable?"
 W !,"  ------------   ----------",?50,"------------   ----------"
 ;
 S B="" F  S B=$O(@DDSBLK@(B)) Q:B=""  D
 . W !,"  "_B,?17,$P(@DDSBLK@(B),U),?54
 . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO")
 . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES")
 Q
 ;
COMMON(B,F) ;Is block B found on forms other than F
 N C,F1
 S C=0,F1=""
 F  S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1=""  I F1'=F S C=1 Q
 I 'C S F1="" F  S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1=""  I F1'=F S C=1 Q
 Q C

DDSFO
DDSFO ;SFISC/MKO-FORM ONLY FIELDS ;02:46 PM  8 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIR ;Setup input variables to DIR
 N I,J
 S DIR(0)=$P(DDSO(20),U)_$P(DDSO(20),U,2,3)
 S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
 S:$P(DIR(0),U)'["O" $P(DIR(0),U)=$P(DIR(0),U)_"O"
 I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D
 . S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z"
 . S $P(I,":",2)=$P(I,":",2)_"Z"
 . S $P(DIR(0),U,2)=I
 S:$G(^DIST(.404,DDSBK,40,DDO,22))'?."^" DIR(0)=DIR(0)_U_^(22)
 I $D(^DIST(.404,DDSBK,40,DDO,21)) D
 . S (I,J)=0
 . F  S I=$O(^DIST(.404,DDSBK,40,DDO,21,I)) Q:I=""  I $D(^(I,0))#2 S J=J+1,DIR("?",J)=^(0)
 . I J>0 S DIR("?")=DIR("?",J) K DIR("?",J)
 X:$G(^DIST(.404,DDSBK,40,DDO,24))'?."^" ^(24)
 Q

DDSIT
DDSIT ;SFISC/MKO-INPUT TRANSFORMS ;09:07 AM  24 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PFIELD ;Input transform for the PARENT FIELD field of the PAGE multiple
 ;of the Form file.
 N DDSMF
 S DDSMF=$$GETFLD^DDSLIB($P(X,","),$P(X,",",2),$P(X,",",3),DA(1))
 G QUIT
 ;
PLINK ;Input transform for POINTER LINK field of the BLOCK multiple of
 ;the PAGE MULTIPLE of the Form file.
 N DDP,DDSCD,DDSERR,DDS
 ;
 S DDP=$P($G(^DIST(.403,DA(2),0)),U,8)
 I 'DDP D  G QUIT
 . N P
 . S P(1)="PRIMARY FILE",P(2)="FORM"
 . D BLD^DIALOG(3011,.P)
 ;
 S DDS=DA(2)_U_$P(^DIST(.403,DA(2),0),U)
 D:X?1"FO(".E FO^DDSPTR(DDP,X,DA(2),DA(1))
 D:X'?1"FO(".E DD^DDSPTR(DDP,X,DA)
 G QUIT
 ;
CEXPR ;Input transform for COMPUTED EXPRESSION field
 N DDP,DDSX,DDSNEXP
 S DDP=$P($G(^DIST(.404,DA(1),0)),U,2)
 D PARSE^DDSCOMP(DDP,X,DA(1),.DDSNEXP) G:$G(DIERR) QUIT
 ;
 S DDSX=X,X=DDSNEXP D ^DIM S:$D(X) X=DDSX
 Q
 ;
QUIT ;Check error and quit
 I $G(DIERR) N DDSERR D MSG^DIALOG("AB",.DDSERR),EN^DDIOL(.DDSERR) K X
 Q

DDSLIB
DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;01:37 PM  6 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos
 ;after the next occurrence of char C, ignoring those within quoted
 ;strings.
 N I,J,P
 S:'$D(S) S=1
 F  D  Q:$D(P)
 . S I=$F(E,C,S),J=$F(E,"""",S)
 . I 'I S P=I Q
 . I J,J<I S S=$$AFTQ(E,J-1) Q
 . S P=I
 Q P
 ;
PIECE(E,C,N1,N2) ;Return the N1th to N2th C-piece of E
 ;ignoring those within quoted strings
 ;Start looking from pos 1
 N I,J,S,F
 S:'$D(N1) N1=1 Q:'N1
 S:'$D(N2) N2=N1 Q:N2<N1
 S S=1 F I=1:1:N1-1 S S=$$FIND(E,C,S) Q:'S
 Q:'S $S(N1=1:E,1:"")
 S F=S F I=1:1:N2-N1+1 S F=$$FIND(E,C,F) Q:'F
 Q:'F $E(E,S,999)
 Q $E(E,S,F-2)
 ;
RPAR(E,S) ;Find in expression E, from char pos S (the position
 ;of the left paren) the char pos after the right paren,
 ;ignoring nested parens, or parens within quotes
 N I,L,P,R
 S P=1,I=S+1
 F  D  Q:'P
 . S R=$$FIND(E,")",I),L=$$FIND(E,"(",I)
 . I L,L<R S P=P+1,I=L Q
 . S P=P-1,I=R
 Q I
 ;
AFTQ(E,I) ;Return character position after quoted string
 ;E = string, I=character position of first quote
 S:'$G(I) I=1
 F  S I=$F(E,"""",I+1) Q:$E(E,I)'=""""
 S:'I I=$L(E)+1
 Q I
 ;
QT(X) ;Return X quoted
 Q:$G(X)="" """"""
 S X(X)="",X=$Q(X(""))
 Q $E(X,3,$L(X)-1)
 ;
UQT(X) ;Return quoted string X unquoted
 Q:$G(X)="" ""
 S @("X("_X_")=""""")
 Q $O(X(""))
 ;
FIELD(DDP,FLD) ;Get field number
 N F,P
 I FLD="" D BLD^DIALOG(202,"field") Q ""
 S:$E(FLD)="""" FLD=$$UQT($E(FLD,1,$$AFTQ(FLD)-1))
 S F=FLD,P("FILE")=DDP
 I FLD'=+$P(FLD,"E") D  Q:$G(DIERR) ""
 . S F=$O(^DD(DDP,"B",FLD,""))
 . I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
 ;
 I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
 Q F
 ;
GETFLD(FD,BK,PG,DDS,DDSPG,DDSBK,DDSFLG) ;Return "DDO,bk#,pg#"
 ;DDSPG=current page, DDSBK=current block
 ; -- when block and page are optional
 ;PG is required only if block order is sent
 ;DDSFLG["F" means field must be form-only
 N F,B,P,N
 I FD?.N.1"."1.N1",".N.1"."1.N,BK="",PG="" Q FD
 S:$E($G(FD))="""" FD=$$UQT(FD)
 S:$E($G(BK))="""" BK=$$UQT(BK)
 S:$E($G(PG))="""" PG=$$UQT(PG)
 S P=+$G(DDSPG),B=+$G(DDSBK)
 D @$S($G(PG)]"":"PG",$G(BK)]"":"BK",1:"FD") Q:$G(DIERR) ""
 Q F_","_B_","_P
 ;
PG ;Get internal page number
 I '$G(DDS) D BLD^DIALOG(3084) Q
 S N=PG=+$P(PG,"E")
 I N S P=$O(^DIST(.403,+DDS,40,"B",PG,""))
 E  I PG?1"`".N.1"."1.N S P=+$P(PG,"`",2),N=2
 E  S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(PG),""))
 ;
 I $D(^DIST(.403,+DDS,40,+P,0))[0 D BLD^DIALOG(3023,$S(N=2:"#",N:"number ",1:"named ")_PG) Q
 ;
 I BK="" D  Q:$G(DIERR)
 . S BK=$O(^DIST(.403,+DDS,40,P,40,"AC",""))
 . I BK="" D BLD^DIALOG(3055,$S(N:"number ",1:"named ")_PG)
 ;
BK ;Get internal block number
 S N=BK=+$P(BK,"E")
 I N D  Q:$G(DIERR)
 . I P S B=$O(^DIST(.403,+DDS,40,P,40,"AC",BK,"")) Q
 . D BLD^DIALOG(3085)
 E  I BK?1"`".N.1"."1.N S B=+$P(BK,"`",2),N=2
 E  D  Q:$G(DIERR)
 . S B=$O(^DIST(.404,"B",BK,""))
 . I B="" D BLD^DIALOG(3051,BK) Q
 . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
 ;
 I P,$D(^DIST(.403,+DDS,40,P,40,+B,0))[0 D  Q
 . N P1
 . S P1(1)=$S(N=2:"#",N:"order ",1:"")_BK
 . S P1(2)="number "_$P(^DIST(.403,+DDS,40,P,0),U)_$S($G(^(1))]"":" ("_$P(^(1),U)_")",1:"")
 . D BLD^DIALOG(3053,.P1)
 ;
 I FD="" D  Q:$G(DIERR)
 . S FD=$O(^DIST(.404,B,40,"B",""))
 . D:FD="" BLD^DIALOG(3071,$P(^DIST(.404,B,0),U))
 ;
FD ;Get internal field number
 I 'B D BLD^DIALOG(3082) Q
 S N=FD=+$P(FD,"E")
 I N S F=$O(^DIST(.404,B,40,"B",FD,""))
 E  I FD?1"`".N.1"."1.N S F=+$P(FD,"`",2),N=2
 E  D  Q:$G(DIERR)
 . N X
 . S FD=$$UPCASE(FD),X=$S($D(^DIST(.404,B,40,"D",FD)):"D",1:"C")
 . S F=$O(^DIST(.404,B,40,X,FD,""))
 ;
 I $D(^DIST(.404,B,40,+F,0))[0 D
 . N P
 . S P(1)=$S(N=2:"#",N:"order ",1:"with caption or unique name ")_FD
 . S P(2)=$P(^DIST(.404,B,0),U)
 . D BLD^DIALOG(3072,.P)
 ;
 I '$G(DIERR),$G(DDSFLG)["F","^2^4^"'[(U_$P($G(^DIST(.404,B,40,+F,0)),U,3)_U) D BLD^DIALOG(3081)
 Q
 ;
UPCASE(X) ;
 ;Return X in uppercase
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDSM
DDSM ;SFISC/MKO-MULTILINE ;12:51 PM  14 Sep 1995
 ;;21.0;VA FileMan;**6,13,14**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
MNAV(FND) ;Navigate within repeating blocks
 ;Returns FND if navigating to another field within the repeating
 ;block
 N DDSCL,DDSDDO,DDSNR,DDSPDA,DDSSN,DDSSTL
 S DDSDDO=$P(DDSU("N"),U,$L($P("U^D^R^L^N",DDACT),U)+5)
 ;
 S DDSPDA=$P(DDSREP,U),DDSSTL=$P(DDSREP,U,2),DDSCL=$P(DDSREP,U,3)
 S DDSSN=$P(DDSREP,U,4),DDSNR=$P(DDSREP,U,5)
 ;
 I $P(DDSDDO,",",2)="-1" D MUP Q
 I $P(DDSDDO,",",2)="+1" D MDN Q
 I DA S DDO=+DDSDDO,FND=1 Q
 Q
 ;
MUP ;Move up a line
 Q:DDSSN'>1
 S DDSSN=DDSSN-1
 I DDSCL>1 D
 . S DDSCL=DDSCL-1 D MDA
 E  D
 . S DDSSTL=DDSSTL-1
 . D MDA,DB^DDSR(DDSPG,DDSBK)
 Q
 ;
MDN ;Move down a line
 Q:'DA
 S DDSSN=DDSSN+1
 I DDSCL<DDSNR D
 . S DDSCL=DDSCL+1 D MDA
 E  D
 . S DDSSTL=DDSSTL+1
 . D MDA,DB^DDSR(DDSPG,DDSBK)
 Q
 ;
MDA ;Update DDO, DA and Dn, set FND=1
 N DDSDASV
 S $P(DDSREP,U,2,4)=DDSSTL_U_DDSCL_U_DDSSN
 S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
 S DDSDASV=DDSDA
 S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999))
 S DA=+DDSDA,@("D"_DDSDL)=DA
 S DDO=$S(DA:+DDSDDO,1:$P(DDSREP,U,8))
 S FND=1
 Q
 ;
SEL ;Issue read
 N DIRUT
 S DIR(0)="PO"_DIE_":QEMZ"_$E("L",'$D(DDSTP)&'$P(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,2),U,4))
 I $P(DDSREP,U,7) D
 . S:$D(@(DIE_"0)"))[0 @(DIE_"0)")=U_$P(^DD($P(DDSREP,U,6),$P(DDSREP,U,7),0),U,2)_U_U
 E  D
 . S DIR("S")="I $D("_DIE_""""_$P(DDSREP,U,9)_""","_+$P(DDSREP,U)_",Y))"
 D ^DIR K DIR,DUOUT,DIROUT Q:DIR0N!$D(DIRUT)
 ;
 S DA=+Y,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA
 I $P(Y,U,3)=1 D
 . N DDSFN,DDSLN,DDSPDA,DDSSN
 . S DDSPDA=$P(DDSREP,U),DDSLN=$P(DDSREP,U,3),DDSSN=$P(DDSREP,U,4)
 . S DDSFN=+$P(@DDSREFS@(DDSPG,DDSBK),U,3)
 . ;
 . I '$P(DDSREP,U,7) D
 .. N DR,X,Y
 .. S DR=$O(^DD(DDSFN,0,"IX",$P(DDSREP,U,9),DDSFN,""))_"////"_+DDSREP
 .. D ^DIE
 . ;
 . D ADD(DDSDA,DDSPDA,DDSSN)
 . S DDSFN="F"_DDSFN
 . D DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN)
 . S DDSCHKQ=2
 E  D
 . S DDSCHKQ=1
 . D POSDA(DDSDA)
 ;
 S Y=$P(Y,U)
 S:X="" Y=""
 Q
 ;
END ;
 S DDACT="N"
 Q:'DA
 D POSSN(999999999999)
 Q
 ;
PGDN ;Page down
 S DDACT="N"
 I 'DA D
 . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP"
 E  D POSSN($P(DDSREP,U,2)+$P(DDSREP,U,5))
 Q
 ;
PGUP ;Page up
 S DDACT="N"
 I $P(DDSREP,U,4)=1 D
 . S DDSPG=$$PP^DDS5(.Y)
 . S:Y=1 DDACT="NP"
 E  D POSSN($P(DDSREP,U,2)-$P(DDSREP,U,5))
 Q
 ;
POSSN(DDSSN,DDSPAINT) ;Make line with given DDSSN current
 N DDSLSN,DDSPDA,DDSSTL
 S DDSPDA=$P(DDSREP,U)
 S DDSSTL=$P(DDSREP,U,2)
 ;
 S DDSLSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)+1
 S DDSSN=$$MIN(DDSLSN,DDSSN)
 S:DDSSN<1 DDSSN=1
 ;
 S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999))
 S DA=+DDSDA,@("D"_DDSDL)=DA
 ;
 S:'DA DDO=$P(DDSREP,U,8)
 I DDSSN'<DDSSTL,DDSSN<(DDSSTL+$P(DDSREP,U,5)) D
 . S $P(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
 . S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
 . D:$G(DDSPAINT) DB^DDSR(DDSPG,DDSBK)
 E  D
 . S DDSSTL=$$MIN(DDSLSN-$P(DDSREP,U,5)+1,DDSSN)
 . S:DDSSTL<1 DDSSTL=1
 . S $P(DDSREP,U,2,4)=DDSSTL_U_(DDSSN-DDSSTL+1)_U_DDSSN
 . S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
 . D DB^DDSR(DDSPG,DDSBK)
 Q
 ;
POSDA(DDSDA) ;Make line with given DDSDA current
 N DDSPDA,DDSSN,DDSSTL
 S DDSSN=@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),"B",DDSDA)
 S DDSPDA=$P(DDSREP,U),DDSSTL=$P(DDSREP,U,2)
 ;
 I DDSSN'<DDSSTL,DDSSN<(DDSSTL+$P(DDSREP,U,5)) D
 . N DY,DX
 . S $P(DDSREP,U,3,4)=DDSSN-DDSSTL+1_U_DDSSN
 . S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
 . S DY=$P(DIR0,U),DX=$P(DIR0,U,2) X IOXY W $J("",$P(DIR0,U,3))
 E  D
 . S $P(DDSREP,U,2,4)=DDSSN_"^1^"_DDSSN
 . S $P(@DDSREFT@(DDSPG,DDSBK,DDSPDA),U,2,999)=DDSREP
 . D DB^DDSR(DDSPG,DDSBK)
 Q
 ;
ADD(DDSDA,DDSPDA,DDSSN) ;Add entry
 S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN
 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIE
 S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA
 D ^DDS11(DDSBK)
 S DDSCHG=1
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDSM1
DDSM1 ;SFISC/MKO-MULTILINE, LOAD AND DELETE ;2:23 PM  9 Feb 1996
 ;;21.0;VA FileMan;**6,13,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
LOAD(DDSIEN) ;Load subentries
MLOAD ;Entry point from MLOAD^DDSUTL
 ;@DDSIEN is an array of record numbers
 ;
 Q:$D(DDSIEN)[0
 Q:$D(@DDSIEN)<9
 ;
 N DDSI,DDSPDA,DDSRN,DDSSN
 S DDSPDA=$P(DDSREP,U)
 S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)
 ;
 ;Add records to internal ^TMP array
 ;Load data for each record
 S DDSI="" F  S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI=""  D
 . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN
 . S DA=+DDSRN,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA
 . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA))[0 D
 .. S DDSSN=DDSSN+1
 .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN
 .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA
 .. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIE
 . D ^DDS11(DDSBK)
 . S DDSCHG=1
 ;
 ;Position the cursor on blank (Select) line
 ;Repaint all lines in the repeating block
 D POSSN^DDSM(999999999999)
 D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),1)
 ;
 ;Update DIR0
 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
 S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+$P(DDSREP,U,3)-1
 Q
 ;
DEL(DDSIEN) ;Delete subentries
MDEL ;Entry point from MDEL^DDSUTL
 ;In:
 ; If DDSIEN contains a record number, delete that one (G MDELONE)
 ; If DDSIEN contains a closed root, @DDSIEN is an array
 ;  of record numbers to delete
 ; DIE   = global root
 ; DDSDA = current IENS
 ;
 Q:$D(DDSIEN)[0
 G:+$P(DDSIEN,"E") MDELONE
 Q:$D(@DDSIEN)<9
 ;
 N DDSI,DDSPDA,DDSRN,DDSSN
 S DDSPDA=$P(DDSREP,U)
 ;
 ;Loop through passed array and delete subentries
 S DDSI="" F  S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI=""  D
 . ;S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN
 . ;S DDSIENS=DDSDA,$P(DDSIENS,",")=+DDSRN
 . ;D K^DDS6(DDSIENS,DIE)
 . ;Q
 . ;
 . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN
 . S DA=+DDSRN,$P(DDSDA,",")=DA
 . S DDSSN=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)) Q:'DDSSN
 . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)
 . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)
 . K @DDSREFT@("F"_DDP,DDSDA)
 ;
 ;Close up gaps in ^TMP array
 S (DDSI,DDSSN)=0
 F  S DDSI=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI)) Q:'DDSI  D
 . S DDSSN=DDSSN+1 Q:DDSI=DDSSN
 . S DDSRN=@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI)
 . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSRN
 . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSRN)=DDSSN
 ;
 F  S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)) Q:'DDSSN  D
 . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)
 ;
 ;Position cursor on "Select" line
 ;Repaint all lines in repeating block
 D POSSN^DDSM(999999999999,1)
 ;
 ;Update DIR0
 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
 S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+$P(DDSREP,U,3)-1
 Q
 ;
MDELONE ;Delete one subentry in the current repeating block
 ;In:  DDSIEN = IENS of record to be deleted
 ;     DDSREP = data for repeating blocks
 ;     DDSDA  = current IENS
 ;     DIE    = current global root
 ;
 N DDSPDA,DDSRN,DDSSN
 ;
 ;Get parent IENS
 S DDSPDA=$P(DDSREP,U)
 ;
 ;Kill all data pertaining to current (sub)record
 D K^DDS6(DDSIEN,DIE)
 ;
 ;Repaint lines and reposition cursor
 I DDSDA=DDSIEN D
 . D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),$P(DDSREP,U,3))
 . S DDSSN=$P(DDSREP,U,4)
 . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN))[0 D
 .. S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),-1)
 . D POSSN^DDSM(DDSSN)
 ;
 E  D POSSN^DDSM(999999999999,1)
 ;
 ;Update DIR0
 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3)
 S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+$P(DDSREP,U,3)-1
 Q

DDSMSG
DDSMSG ;SFISC/MKO-PRINT MESSAGES ;02:44 PM  9 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ERR ;Print "DIERR" messages in help box
 N DDSE,DDSL,DDSLMT,DDSN
 K DDH,DDQ
 S DDSLMT=$G(DDC,15),DDSE=0
 ;
 W $C(7)
 S DDSN=0
 F  S DDSN=$O(^TMP("DIERR",$J,DDSN)) Q:'DDSN!DDSE  D
 . S DDSL=0
 . F  S DDSL=$O(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)) Q:'DDSL!DDSE  D
 .. D LD($G(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)),"!")
 .. I DDH'<DDSLMT D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
 ;
 I $G(DDH) S:DDH(1,"T")?1.C DDH(1,"T")="" D SC^DDSU
 S DDSKM=1
 K DIERR,^TMP("DIERR",$J)
 Q
 ;
HLP(DDSG) ;Print messages from @DDSG in help area
 N DDSE,DDSL,DDSLMT,DDST
 S:$G(DDSG)="" DDSG=$NA(@DDSREFT@("HLP"))
 ;
 K DDH
 I $D(DDSID),DY-1>DDSHBX!$X D SETDDH
 S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0
 ;
 F  S DDSL=$O(@DDSG@(DDSL)) Q:'DDSL!DDSE  D
 . S DDST=$G(@DDSG@(DDSL))
 . I DDST="$$EOP" S DDH=$G(DDH)+1,DDH(DDH,"E")=""
 . E  D LD(DDST,$G(@DDSG@(DDSL,"F"),"!"))
 . I DDH'<DDSLMT D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
 ;
 I $G(DDH) S:DDH(1,"T")?1.C DDH(1,"T")="" D SC^DDSU
 K:DDSG=$NA(@DDSREFT@("HLP")) @DDSG
 S:'$D(DDSID) DDSKM=1
 Q
 ;
WP(DDSR) ;Print the contents of a wp field @DDSR in help area
 N DDSE,DDSL,DDSLMT
 ;
 K DDH
 I $D(DDSID),DY-1>DDSHBX!$X D SETDDH
 S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0
 ;
 F  S DDSL=$O(@DDSR@(DDSL)) Q:'DDSL!DDSE  D
 . D LD($G(@DDSR@(DDSL,0)),$G(@DDSR@(DDSL,"F"),"!"))
 . I DDH'<DDSLMT D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
 ;
 I $G(DDH) S:DDH(1,"T")?1.C DDH(1,"T")="" D SC^DDSU
 S:'$D(DDSID) DDSKM=1
 Q
 ;
MSG(DDSMSG,DDSFLG,DDSFMT) ;Print local var or array DDSMSG in help area
 ;DDSFLG [ 1 : Write bell
 ;DDSFMT : Format if one line is sent
 N DDSL
 K DDH
 I $D(DDSID),DY-1>DDSHBX!$X D SETDDH
 ;
 I $D(DDSMSG)=1 D
 . D LD(DDSMSG,$S($G(DDSFMT)]"":DDSFMT,1:"!"))
 ;
 E  S DDSL=0 F  S DDSL=$O(DDSMSG(DDSL)) Q:'DDSL  D
 . D LD($G(DDSMSG(DDSL)),$G(DDSMSG(DDSL,"F"),"!"))
 Q:'$G(DDH)
 ;
 I $G(DDH) D
 . S:DDH(1,"T")?1.C DDH(1,"T")=""
 . S:$G(DDSFLG)[1 DDH(1,"T")=$C(7)_DDH(1,"T")
 . D SC^DDSU
 S:'$D(DDSID) DDSKM=1
 Q
 ;
SETDDH ;Setup DDH and DDQ for identifiers and executable help
 ;that called EN^DDIOL
 S DDH=1
 S DDH(1,"T")=$TR($J("",$X)," ",$C(0))
 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)-1_U_$X
 Q
 ;
LD(S,F) ;Load string S with format F into DDH array
 N A,C,J,L
 S DDH=+$G(DDH)
 F J=1:1:$L(F,"!")-1 S DDH=DDH+1,DDH(DDH,"T")=""
 S:'DDH DDH=1
 S:F["?" @("C="_$P(F,"?",2))
 S L=$G(DDH(DDH,"T"))
 S S=L_$J("",$G(C)-$L(L))_S
 ;
 D WRAP(S,.A,IOM-1)
 S DDH=DDH-1
 F A=1:1:A S DDH=$G(DDH)+1,DDH(DDH,"T")=A(A)
 Q
 ;
WRAP(L,A,M) ;Wrap line at word boundaries
 ; L    = Line of text
 ; M    = Margin width
 ;Return:
 ; A    = Number of lines
 ; A(n) = Array of text
 ;
 S:'$G(M) M=$S($G(IOM):IOM-5,1:75)
 N I,N
 S N=0
 F I=$L(L," "):-1:1 D  Q:L=""
 . I I=1 S N=N+1,A(N)=$E(L,1,M),L=$E(L,M+1,999) Q
 . I $L($P(L," ",1,I))'>M D
 .. S N=N+1,A(N)=$P(L," ",1,I),L=$P(L," ",I+1,999)
 S A=N
 Q

DDSOPT
DDSOPT ;SFISC/MLH,MKO-SCREENMAN OPTIONS ;07:32 AM  15 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DDS"","
 G OPT:$D(^DOPT("DDS",1)) S ^(0)="SCREENMAN OPTION^1.01" K ^("B")
 F X=1:1:4 S ^DOPT("DDS",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK
OPT ;
 S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
 ;
EN ;Entry point for all screenman options
 D @DI W !!
Q K %,DI,DIC,DIK,X,Y Q
 ;
1 ;;EDIT/CREATE A FORM
CREATE G ^DDGF
 ;
2 ;;RUN A FORM
 G ^DDSRUN
 ;
3 ;;DELETE A FORM
 G ^DDSDFRM
 ;
4 ;;PURGE UNUSED BLOCKS
 G ^DDSDBLK

DDSPRNT
DDSPRNT ;SFISC/MKO-PRINT A FORM ;02:51 PM  18 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 ;
 N DDSFORM,DDSPBRK
 D SELFORM(.DDSFORM) Q:DDSFORM=-1
 D PAGEBRK(.DDSPBRK) Q:$D(DDSPBRK)[0
 ;
 ;Device
 S %ZIS=$S($D(^%ZTSK):"Q",1:"")
 W ! D ^%ZIS K %ZIS I $G(POP) K POP Q
 K POP
 ;
 ;Queue report
 I $D(IO("Q")),$D(^%ZTSK) D  G END
 . S ZTRTN="PRINT^DDSPRNT"
 . S ZTDESC="Report of Form "_$P(DDSFORM,U,2)
 . N I F I="DDSFORM","DDSFORM(0)","DDSPBRK" S ZTSAVE(I)=""
 . D ^%ZTLOAD
 . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
 . E  W !,"Report canceled!",!
 . K ZTSK
 . S IOP="HOME" D ^%ZIS
 ;
 U IO
 ;
PRINT ;Entry point for queued reports
 N DDSBK,DDSCOL1,DDSCOL2,DDSCOL3,DDSCRT,DDSFILE
 N DDSHLIN,DDSHBK,DDSPAGE,DDSQUE
 N DX,DY,X,Y
 ;
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 D INIT
 D @("HDR"_(2-DDSCRT))
 D FORM,END
 Q
 ;
FORM ;Form data
 W !
 ;
 ;Description
 D WP($NA(^DIST(.403,+DDSFORM,15))) Q:$D(DIRUT)
 ;
 ;Other properties
 D W("PRIMARY FILE: "_$P(DDSFORM(0),U,8),9) Q:$D(DIRUT)
 W ?49,"READ ACCESS: "_$P(DDSFORM(0),U,2)
 D W("DATE CREATED: "_$$EXTERNAL^DILFD(.403,4,"",$P(DDSFORM(0),U,5)),9) Q:$D(DIRUT)
 W ?48,"WRITE ACCESS: "_$P(DDSFORM(0),U,3)
 D W("DATE LAST USED: "_$$EXTERNAL^DILFD(.403,5,"",$P(DDSFORM(0),U,6)),7) Q:$D(DIRUT)
 W ?53,"CREATOR: "_$P(DDSFORM(0),U,4)
 D W() Q:$D(DIRUT)
 ;
 I $P(DDSFORM(0),U,7)]"" D W("TITLE: "_$P(DDSFORM(0),U,7),16) Q:$D(DIRUT)
 I $P($G(^DIST(.403,+DDSFORM,21)),U)]"" D W("RECORD SELECTION PAGE: "_$P(^(21),U)) Q:$D(DIRUT)
 ;
 I $X D W() Q:$D(DIRUT)
 S X=$G(^DIST(.403,+DDSFORM,11))
 I X]"" D W("PRE ACTION:",11) Q:$D(DIRUT)  D PCOL(X,23)
 S X=$G(^DIST(.403,+DDSFORM,12))
 I X]"" D W("POST ACTION:",10) Q:$D(DIRUT)  D PCOL(X,23)
 S X=$G(^DIST(.403,+DDSFORM,14))
 I X]"" D W("POST SAVE:",12) Q:$D(DIRUT)  D PCOL(X,23)
 S X=$G(^DIST(.403,+DDSFORM,20))
 I X]"" D W("DATA VALIDATION:",6) Q:$D(DIRUT)  D PCOL(X,23)
 K DDSFORM(0)
 ;
 ;Loop through all pages
 I $X D W() Q:$D(DIRUT)
 Q:'$O(^DIST(.403,+DDSFORM,40,0))
 ;
 N DDSPG,DDSPGN
 S DDSPGN="",DDSPFRST=1
 F  S DDSPGN=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN)) Q:DDSPGN=""!$D(DIRUT)  S DDSPG=0 F  S DDSPG=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN,DDSPG)) Q:'DDSPG!$D(DIRUT)  D PAGE^DDSPRNT1
 K DDSPFRST Q:$D(DIRUT)
 ;
 D:$D(DDSHBK) HBLKS^DDSPRNT1
 Q
 ;
WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value
 I DDSVAL="",'$G(DDSFLG) Q
 ;
 D W() Q:$D(DIRUT)
 W ?DDSCOL2,DDSLAB
 ;
 I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1
 D PCOL(DDSVAL,DDSCOL3)
 Q
 ;
PCOL(DDSVAL,DDSCOL) ;Print DDSVAL
 N DDSWIDTH,DDSIND
 S DDSWIDTH=IOM-DDSCOL-1
 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D  Q:$D(DIRUT)
 . I DDSIND>1 D W() Q:$D(DIRUT)
 . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
 Q
 ;
WP(DDSWP,DIWL,DDSLF) ;Print text in array @DDSWP
 ;DDSLF [ A : LF after (def)
 ;        B : LF feed before
 ;
 Q:'$P($G(@DDSWP@(0)),U,3)
 N DIW,DIWF,DIWI,DIWR,DIWT,DIWTC,DIWX,DN
 N DDSI,DDSCNT,I,X,Z
 ;
 K ^UTILITY($J,"W")
 S:'$G(DIWL) DIWL=1
 S DIWR=IOM-1
 S:'$D(DDSLF) DDSLF="A"
 ;
 S DDSCNT=$P($G(@DDSWP@(0)),U,3)
 I DDSCNT D
 . F DDSI=1:1:DDSCNT I $D(@DDSWP@(DDSI,0))#2 S X=^(0) D ^DIWP
 . ;
 . I DDSLF'["B" D
 .. W ?DIWL-1,$G(^UTILITY($J,"W",DIWL,1,0))
 .. S DDSCNT=1
 . E  S DDSCNT=0
 . F  S DDSCNT=$O(^UTILITY($J,"W",DIWL,DDSCNT)) Q:'DDSCNT!$D(DIRUT)  D
 .. D W($G(^UTILITY($J,"W",DIWL,DDSCNT,0)),DIWL-1)
 ;
 K ^UTILITY($J,"W")
 D:DDSLF["A" W()
 Q
 ;
W(DDSSTR,DDSCOL) ;Write DDSSTR
 I $Y+3'<IOSL D HEADER Q:$D(DIRUT)
 W !?+$G(DDSCOL),$G(DDSSTR)
 Q
 ;
HEADER ;All headers except first
 I DDSCRT D  Q:$D(DIRUT)
 . N DIR,X,Y
 . S DIR(0)="E" W ! D ^DIR
 I DDSQUE,$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
 ;
HDR1 ;First header for CRTs
 W @IOF
 ;
HDR2 ;First header for non-CRTs
 ;
 S DDSPAGE=$G(DDSPAGE)+1
 W "FORM LISTING - "_$P(DDSFORM,U,2)_" (#"_+DDSFORM_")"
 W !,"FILE: "_DDSFILE
 W ?(IOM-$L(DDSHLIN)-$L(DDSPAGE)-1),DDSHLIN_DDSPAGE
 W !,$TR($J("",IOM-1)," ","-")
 Q
 ;
SELFORM(DDSFORM) ;Select form
 N %,%W,%Y,C,I,Q,DDH,DIC,X,Y
 S DIC="^DIST(.403,",DIC(0)="QEAMZ"
 D ^DIC K DIC
 S DDSFORM=Y,DDSFORM(0)=$G(Y(0))
 Q
 ;
PAGEBRK(DDSPBRK) ;Prompt
 N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
 S DIR(0)="YO"
 S DIR("A")="Start each page of the form on a new page"
 S DIR("B")="Yes"
 W ! D ^DIR Q:$D(DIRUT)
 S DDSPBRK=Y
 Q
 ;
INIT ;Setup
 N %,%H,X,Y
 S %H=$H D YX^%DTC
 S DDSHLIN=$P(Y,"@")_"  "_$P($P(Y,"@",2),":",1,2)_"    PAGE "
 S DDSFILE=$P(DDSFORM(0),U,8)
 I DDSFILE,$D(^DIC(DDSFILE,0))#2 S DDSFILE=$P(^(0),U)_" (#"_DDSFILE_")"
 E  S DDSFILE=""
 S DDSCRT=$E(IOST,1,2)="C-"
 S DDSQUE=$D(ZTQUEUED)
 Q
 ;
END ;Finish up
 I $D(ZTQUEUED) S ZTREQ="@"
 E  X $G(^%ZIS("C"))
 K DIRUT,DUOUT,DTOUT
 Q

DDSPRNT1
DDSPRNT1 ;SFISC/MKO-PRINT A FORM ;11:49 AM  17 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PAGE ;Print page properties
 I $Y+7'<IOSL!(DDSPBRK&'$D(DDSPFRST)) D HEADER^DDSPRNT Q:$D(DIRUT)
 I DDSPBRK!$D(DDSPFRST) D
 . W !,"Page    Page"
 . W !,"Number  Properties"
 . W !,"------  ----------"
 K DDSPFRST
 ;
 S DDSCOL1=0,DDSCOL2=8,DDSCOL3=32
 F X=0,1 S DDSPG(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,X))
 Q:DDSPG(0)=""
 ;
 D W() Q:$D(DIRUT)
 W ?DDSCOL1,$P(DDSPG(0),U),?DDSCOL2,$P(DDSPG(1),U)
 ;
 D W() Q:$D(DIRUT)
 D WP^DDSPRNT($NA(^DIST(.403,+DDSFORM,40,DDSPG,15)),DDSCOL2+1)
 Q:$D(DIRUT)
 ;
 S X=$P(DDSPG(0),U,2)
 I X]"" D  Q:$D(DIRUT)
 . D WR("HEADER BLOCK:",$P($G(^DIST(.404,X,0)),U)_" (#"_X_")")
 . S DDSHBK(X)=""
 ;
 D WR("PAGE COORDINATE:",$P(DDSPG(0),U,3)) Q:$D(DIRUT)
 I $P(DDSPG(0),U,6) D WR("IS THIS A POP UP PAGE?:","YES") Q:$D(DIRUT)
 D WR("LOWER RIGHT COORDINATE:",$P(DDSPG(0),U,7)) Q:$D(DIRUT)
 ;
 D WR("NEXT PAGE:",$P(DDSPG(0),U,4)) Q:$D(DIRUT)
 D WR("PREVIOUS PAGE:",$P(DDSPG(0),U,5)) Q:$D(DIRUT)
 D WR("PARENT FIELD:",$P(DDSPG(1),U,2)) Q:$D(DIRUT)
 ;
 D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,11))) Q:$D(DIRUT)
 D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,12))) Q:$D(DIRUT)
 K DDSPG(0),DDSPG(1)
 ;
 ;Loop through all blocks
 I $X D W() Q:$D(DIRUT)
 Q:'$O(^DIST(.403,+DDSFORM,40,DDSPG,40,0))
 ;
 I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
 W !?DDSCOL2,"Block  Block"
 W !?DDSCOL2,"Order  Properties (Form File)"
 W !?DDSCOL2,"-----  ----------------------"
 ;
 N DDSBKO
 S DDSBKO=""
 F  S DDSBKO=$O(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO)) Q:DDSBKO=""!$D(DIRUT)  S DDSBK=0 F  S DDSBK=$O(^DIST(.403,+DDSFORM,40,DDSPG,40,"AC",DDSBKO,DDSBK)) Q:'DDSBK!$D(DIRUT)  D BLOCK
 Q
 ;
BLOCK ;Print Block properties
 S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
 F X=0,1,2 S DDSBK(X)=$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,X))
 Q:DDSBK(0)=""
 ;
 D W($P(DDSBK(0),U,2),DDSCOL1) Q:$D(DIRUT)
 W ?DDSCOL2,$P($G(^DIST(.404,DDSBK,0)),U)_" (#"_DDSBK_")"
 D W() Q:$D(DIRUT)
 ;
 D WR("TYPE OF BLOCK:",$$EXTERNAL^DILFD(.4032,3,"",$P(DDSBK(0),U,4))) Q:$D(DIRUT)
 D WR("BLOCK COORDINATE:",$P(DDSBK(0),U,3)) Q:$D(DIRUT)
 D WR("POINTER LINK:",$P(DDSBK(1),U)) Q:$D(DIRUT)
 D WR("REPLICATION:",$P(DDSBK(2),U)) Q:$D(DIRUT)
 D WR("INDEX:",$P(DDSBK(2),U,2)) Q:$D(DIRUT)
 D WR("INITIAL POSITION:",$P(DDSBK(2),U,3)) Q:$D(DIRUT)
 D WR("DISALLOW LAYGO",$P(DDSBK(2),U,4)) Q:$D(DIRUT)
 D WR("FIELD FOR SELECTION:",$P(DDSBK(2),U,5)) Q:$D(DIRUT)
 ;
 D WR("PRE ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,11))) Q:$D(DIRUT)
 D WR("POST ACTION:",$G(^DIST(.403,+DDSFORM,40,DDSPG,40,DDSBK,12))) Q:$D(DIRUT)
 ;
 K DDSBK(1),DDSBK(2)
 S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
 ;
 I $Y+6'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
 W !!?DDSCOL2,"Block Properties (Block File)"
 W !,?DDSCOL2,"-----------------------------"
 D BLOCK^DDSPRNT2
 Q
 ;
HBLKS ;Header blocks
 Q:'$D(DDSHBK)
 I $Y+7'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
 W !!,"Header Block Properties"
 W !,"------------------------"
 S DDSCOL1=8,DDSCOL2=15,DDSCOL3=39
 S DDSBK="" F  S DDSBK=$O(DDSHBK(DDSBK)) Q:'DDSBK!$D(DIRUT)  D
 . S DDSBK(0)=$G(^DIST(.404,DDSBK,0)) Q:DDSBK(0)=""
 . D W("NAME: "_$P(DDSBK(0),U)_" (#"_DDSBK_")") Q:$D(DIRUT)
 . D W() Q:$D(DIRUT)
 . D BLOCK^DDSPRNT2
 . D W() Q:$D(DIRUT)
 Q
 ;
WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value
 I DDSVAL="",'$G(DDSFLG) Q
 ;
 D W() Q:$D(DIRUT)
 W ?DDSCOL2,DDSLAB
 ;
 I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1
 D PCOL(DDSVAL,DDSCOL3)
 Q
 ;
PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL
 N DDSWIDTH,DDSIND
 S DDSWIDTH=IOM-DDSCOL-1
 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D  Q:$D(DIRUT)
 . I DDSIND>1 D W() Q:$D(DIRUT)
 . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
 Q
 ;
W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL
 I $Y+3'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
 W !?+$G(DDSCOL),$G(DDSSTR)
 Q

DDSPRNT2
DDSPRNT2 ;SFISC/MKO-PRINT A FORM ;10:52 AM  23 Aug 1995
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
BLOCK ;Print Block properties from Block file
 D WP^DDSPRNT($NA(^DIST(.404,DDSBK,15)),DDSCOL2+1,"AB") Q:$D(DIRUT)
 ;
 D WR("DATA DICTIONARY NUMBER:",$P(DDSBK(0),U,2),1) Q:$D(DIRUT)
 S X=$P(DDSBK(0),U,3)
 I X]"" D WR("DISABLE NAVIGATION:",$$EXTERNAL^DILFD(.404,2,"",$P(DDSBK(0),U,3))) Q:$D(DIRUT)
 ;
 D WR("PRE ACTION:",$G(^DIST(.404,DDSBK,11))) Q:$D(DIRUT)
 D WR("POST ACTION:",$G(^DIST(.404,DDSBK,12))) Q:$D(DIRUT)
 K DDSBK(0)
 ;
 ;Loop through all fields
 I $X D W() Q:$D(DIRUT)
 Q:'$O(^DIST(.404,DDSBK,40,0))
 ;
 D:$Y+7'<IOSL HEADER^DDSPRNT Q:$D(DIRUT)
 W !?DDSCOL2,"Field  Field"
 W !?DDSCOL2,"Order  Properties"
 W !?DDSCOL2,"-----  ----------"
 ;
 N DDSFD,DDSFDO
 S DDSFDO=""
 F  S DDSFDO=$O(^DIST(.404,DDSBK,40,"B",DDSFDO)) Q:DDSFDO=""!$D(DIRUT)  S DDSFD=0 F  S DDSFD=$O(^DIST(.404,DDSBK,40,"B",DDSFDO,DDSFD)) Q:'DDSFD!$D(DIRUT)  D FIELD
 ;
 Q
 ;
FIELD ;Print Block properties
 S DDSCOL1=15,DDSCOL2=22,DDSCOL3=45
 F X=0,2,4,20 S DDSFD(X)=$G(^DIST(.404,DDSBK,40,DDSFD,X))
 Q:DDSFD(0)=""
 ;
 D W(DDSFDO,DDSCOL1) Q:$D(DIRUT)
 W ?DDSCOL2,"FIELD TYPE:"
 W ?DDSCOL3,$$EXTERNAL^DILFD(.4044,2,"",$P(DDSFD(0),U,3))
 ;
 D WR("CAPTION:",$P(DDSFD(0),U,2)) Q:$D(DIRUT)
 D WR("EXECUTABLE CAPTION:",$G(^DIST(.404,DDSBK,40,DDSFD,.1))) Q:$D(DIRUT)
 D WR("DISPLAY GROUP:",$P(DDSFD(0),U,4)) Q:$D(DIRUT)
 ;
 D WR("UNIQUE NAME:",$P(DDSFD(0),U,5)) Q:$D(DIRUT)
 ;
 D WR("FIELD:",$P($G(^DIST(.404,DDSBK,40,DDSFD,1)),U)) Q:$D(DIRUT)
 D WR("COMPUTED EXPRESSION:",$G(^DIST(.404,DDSBK,40,DDSFD,30))) Q:$D(DIRUT)
 ;
 I DDSFD(20)'?."^" D  Q:$D(DIRUT)
 . D WR("READ TYPE:",$$EXTERNAL^DILFD(.4044,20.1,"",$P(DDSFD(20),U))) Q:$D(DIRUT)
 . D WR("PARAMETERS:",$P(DDSFD(20),U,2)) Q:$D(DIRUT)
 . D WR("QUALIFIERS:",$P(DDSFD(20),U,3)) Q:$D(DIRUT)
 . ;
 . S DDSWP=$NA(^DIST(.404,DDSBK,40,DDSFD,21))
 . I $P($G(@DDSWP@(0)),U,3) D
 .. D W("HELP:",DDSCOL2) Q:$D(DIRUT)
 .. D WP^DDSPRNT(DDSWP,DDSCOL2+3,"B")
 . K DDSWP Q:$D(DIRUT)
 . ;
 . D WR("INPUT TRANSFORM:",$G(^DIST(.404,DDSBK,40,DDSFD,22))) Q:$D(DIRUT)
 . D WR("SAVE CODE:",$G(^DIST(.404,DDSBK,40,DDSFD,23))) Q:$D(DIRUT)
 . D WR("SCREEN:",$G(^DIST(.404,DDSBK,40,DDSFD,24))) Q:$D(DIRUT)
 . K DDSFD(20)
 ;
 D WR("CAPTION COORDINATE:",$P(DDSFD(2),U,3)) Q:$D(DIRUT)
 D WR("DATA COORDINATE:",$P(DDSFD(2),U)) Q:$D(DIRUT)
 D WR("DATA LENGTH:",$P(DDSFD(2),U,2)) Q:$D(DIRUT)
 D WR("SUPPRESS COLON:",$S($P(DDSFD(2),U,4):"YES",1:"")) Q:$D(DIRUT)
 ;
 D WR("DEFAULT:",$P($G(^DIST(.404,DDSBK,40,DDSFD,3)),U)) Q:$D(DIRUT)
 D WR("EXECUTABLE DEFAULT:",$G(^DIST(.404,DDSBK,40,DDSFD,3.1))) Q:$D(DIRUT)
 ;
 I DDSFD(4)'?."^" D
 . D WR("REQUIRED:",$S($P(DDSFD(4),U):"YES",1:"")) Q:$D(DIRUT)
 . D WR("DISABLE EDITING:",$S($P(DDSFD(4),U,4):"YES",1:"")) Q:$D(DIRUT)
 . D WR("RIGHT JUSTIFY:",$S($P(DDSFD(4),U,3):"YES",1:"")) Q:$D(DIRUT)
 . D WR("DISALLOW LAYGO:",$S($P(DDSFD(4),U,5):"YES",1:"")) Q:$D(DIRUT)
 K DDSFD(4)
 ;
 D WR("SUB PAGE LINK:",$P($G(^DIST(.404,DDSBK,40,DDSFD,7)),U,2)) Q:$D(DIRUT)
 ;
 D WR("BRANCHING LOGIC:",$G(^DIST(.404,DDSBK,40,DDSFD,10))) Q:$D(DIRUT)
 D WR("PRE ACTION:",$G(^DIST(.404,DDSBK,40,DDSFD,11))) Q:$D(DIRUT)
 D WR("POST ACTION:",$G(^DIST(.404,DDSBK,40,DDSFD,12))) Q:$D(DIRUT)
 D WR("POST ACTION ON CHANGE:",$G(^DIST(.404,DDSBK,40,DDSFD,13))) Q:$D(DIRUT)
 D WR("DATA VALIDATION:",$G(^DIST(.404,DDSBK,40,DDSFD,14))) Q:$D(DIRUT)
 ;
 D W() Q:$D(DIRUT)
 Q
 ;
WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value
 I DDSVAL="",'$G(DDSFLG) Q
 ;
 D W() Q:$D(DIRUT)
 W ?DDSCOL2,DDSLAB
 ;
 I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1
 D PCOL(DDSVAL,DDSCOL3)
 Q
 ;
PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL
 N DDSWIDTH,DDSIND
 S DDSWIDTH=IOM-DDSCOL-1
 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D  Q:$D(DIRUT)
 . I DDSIND>1 D W() Q:$D(DIRUT)
 . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1)
 Q
 ;
W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL
 I $Y+3'<IOSL D HEADER^DDSPRNT Q:$D(DIRUT)
 W !?+$G(DDSCOL),$G(DDSSTR)
 Q

DDSPTR
DDSPTR ;SFISC/MKO-SET "PT" AND "PTB" NODES ;09:46 AM  24 Oct 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PT(DDSDDP,EXP,DDS,PG,BK) ;Set "PT" and "PTB" nodes
 N DDP,FDL,CD,FD
 S DDP=DDSDDP
 S $P(@DDSREFS@(PG,BK),U,8)=1
 ;
 D:EXP?1"FO(".E FO(DDP,EXP,DDS,PG,BK,.CD,.FDL)
 D:EXP'?1"FO(".E DD(DDP,EXP,BK,.CD,.FDL)
 Q:$G(DIERR)
 ;
 S:FDL?.E1"^" FDL=$E(FDL,1,$L(FDL)-1)
 S @DDSREFS@(PG,BK,"PTB")=FDL
 F CD=1:1:CD S @DDSREFS@(PG,BK,"PTB",CD)=CD(CD)
 F CD=1:1:$L(FDL,U) D
 . S FD=$P($P(FDL,U,CD),";"),DDP=+FD,FD=$P(FD,",",2,99)
 . S @DDSREFS@("PT",DDP,FD,PG,BK)=""
 Q
 ;
DD(DDP,EXP,BK,CD,FDL,COMP) ;Parse DD expression
 ;In:
 ;  DDP  = file #
 ;  EXP  = rel expr
 ;  BK   = blk # (to get DD# of blk)
 ;  COMP = flag, EXP not pointer link
 ;         1, def is ext (DDSCOMP and DDSVAL)
 ;         2, def is int (DDSVAL)
 ;Returns:
 ;  CD   = array of code that sets DA
 ;  FDL  = list of flds used in expr
 ;
 N FD1,FD2,P,PF
 I $G(DDP)="" D BLD^DIALOG(202,"file") Q
LOOP S CD=$G(CD)+1
LOOP1 I $E(EXP)="""" D
 . N I S I=$$AFTQ^DDSLIB(EXP)
 . S FD1=$$UQT^DDSLIB($E(EXP,1,I-1)),FD2=$P($E(EXP,I,999),":",2,999)
 . S P=$P($E(EXP,I,999),":")
 E  D
 . S FD1=$P($P(EXP,":"),";"),FD2=$P(EXP,":",2,999)
 . S P=$P($P(EXP,":"),";",2,999)
 S FD1=$$FIELD^DDSLIB(DDP,FD1) Q:$G(DIERR)
 ;
 S PF=$P(^DD(DDP,FD1,0),U,2)
 I PF S DDP=+PF,EXP=FD2 D:EXP="" BLD^DIALOG(3083) Q:EXP=""  G LOOP1
 ;
 I FD2="",$G(COMP) D  Q
 . S P=$S(COMP=1:P'["I",1:P["E")
 . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(P:","""",""E""",1:"")_")"
 . S FDL=$G(FDL)_DDP_","_FD1_U
 ;
 S PF=+$P(PF,"P",2)
 I PF D
 . S CD(CD)="S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_")"
 . S FDL=$G(FDL)_DDP_","_FD1_U
 . S DDP=PF
 E  D  Q:$G(DIERR)
 . N D,F,S
 . S FDL=$G(FDL)_DDP_","_FD1_";J^"
 . D LKPARM(P,.F,.D,.S)
 . S CD(CD)="N D,DIC,Y S X=$$GET^DDSVAL("_DDP_","_$S(CD=1:".DA",1:"X")_","_FD1_$S(F:"",1:","""",""E""")_")"
 . D GETFF(.FD2,.DDP) Q:$G(DIERR)
 . I FD2="" D  Q:$G(DIERR)
 .. I $G(COMP) D BLD^DIALOG(3083) Q
 .. S DDP=$P(^DIST(.404,BK,0),U,2)
 . I DDP="" D BLD^DIALOG(202,"file") Q
 . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D  Q
 .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
 . S CD(CD)=CD(CD)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
 ;
 I FD2]"" S EXP=FD2 G LOOP
 S CD(CD)=CD(CD)_",DA=X"
 Q
 ;
FO(DDP,EXP,DDS,PG,BK,CD,FDL,COMP) ;Parse FO expression
 N FD1,FD2,I,P
 ;
 S:'$D(DDS) DDS="" S:'$D(PG) PG="" S:'$D(BK) BK=""
 S CD=1
 S I=$$RPAR^DDSLIB(EXP,3)
 S FD1=$E(EXP,4,I-2),P=$P($E(EXP,I,999),":")
 S FD2=$P($E(EXP,I,999),":",2,999)
 F I=1:1:3 S P(I)=$$PIECE^DDSLIB(FD1,",",I)
 ;
 S FD1=$P($$GETFLD^DDSLIB(P(1),P(2),P(3),DDS,PG,BK,"F"),",",1,2)
 Q:$G(DIERR)
 ;
 I FD2="",$G(COMP) D  Q
 . S P=$S(COMP=1:P'["I",1:P["E")
 . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(P:"E",1:"")_""",DDSDA)"
 . S FDL=$G(FDL)_"0,"_FD1_U
 ;
 I $P($G(^DIST(.404,+$P(FD1,",",2),40,+FD1,20)),U)="" D  Q
 . N P S P(1)="READ TYPE",P(2)="form-only field in the BLOCK"
 . D BLD^DIALOG(3011,.P)
 ;
 I $P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U)["P" D
 . S CD(1)="S X=$$GET^DDSVALF("""_FD1_""","""","""","""",DDSDA)"
 . S FDL=$G(FDL)_"0,"_FD1_U
 . S DDP=U_$P($P(^DIST(.404,+$P(FD1,",",2),40,+FD1,20),U,3),":")
 E  D  Q:$G(DIERR)
 . N D,F,S
 . S FDL=$G(FDL)_"0,"_FD1_";J^"
 . D LKPARM(P,.F,.D,.S)
 . S CD(1)="N D,DIC,Y S X=$$GET^DDSVALF("""_FD1_""","""","""","""_$S(F:"",1:"E")_""",DDSDA)"
 . D GETFF(.FD2,.DDP) Q:$G(DIERR)
 . I FD2="" S DDP=$P(^DIST(.404,BK,0),U,2)
 . I DDP="" D BLD^DIALOG(202,"file") Q
 . I '$D(^DD(DDP))!'$D(^DIC(DDP,0,"GL")) D  Q
 .. N P S P("FILE")=DDP D BLD^DIALOG(401,.P)
 . S CD(1)=CD(1)_",DIC="""_^DIC(DDP,0,"GL")_""""_D_S_" S X=+Y"
 ;
 I FD2="" S CD(CD)=CD(CD)_",DA=X"
 E  S EXP=FD2 D DD(DDP,EXP,BK,.CD,.FDL,$G(COMP))
 Q
 ;
GETFF(FD2,DDP) ;Get file, field
 ;Input:  FD2=file:field:...
 ;Output: FD2=field:...
 ;        DDP=file number
 I $E(FD2)="""" D
 . N I S I=$$AFTQ^DDSLIB(FD2,1)
 . S DDP=$$UQT^DDSLIB($E(FD2,1,I-1)),FD2=$E(FD2,I,999)
 E  S DDP=$P(FD2,":"),FD2=$P(FD2,":",2,999)
 ;
 I DDP]"",DDP'=+$P(DDP,"E") D
 . I '$D(^DIC("B",DDP)) D BLD^DIALOG(3012,DDP) Q
 . S DDP=$O(^DIC("B",DDP,""))
 Q
 ;
LKPARM(P,F,D,S) ;Parse lookup params
 ;In:  P = specifiers separated by ;
 ;Out: F = 1 if int form wanted
 ;     D = code that sets D and DIC(0)
 ;     S = code that calls ^DIC
 N I,IP,L,M
 S (D,F,L,M)=""
 F I=1:1:$L(P,";") D
 . S IP=$P(P,";",I) Q:IP=""
 . I IP="I" S F=1 Q
 . I IP="L" S L=1 Q
 . I IP?.1"M"1"IX(".E1")" D  Q
 .. S IP=$P($P(IP,"(",2),")")
 .. S:$E(IP)'="""" IP=$$QT^DDSLIB(IP)
 .. S D=",D="_IP
 .. I $L(IP,U)>1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1"
 .. E  S D=D_",DIC(0)=""F""",S=" D IX^DIC"
 S:D="" D=",DIC(0)=""MF""",S=" D ^DIC"
 S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_""""
 Q

DDSR
DDSR ;SFISC/MKO-PAINT ;8:40 AM  30 Oct 1995
 ;;21.0;VA FileMan;**14**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
R ;All pages
 ;Called after wp, mults, & deletions
 F DDSSC=1:1:DDSSC D RP(DDSSC(DDSSC),DDSSC=1)
 Q
 ;
RP(X,DDS3LIN) ;Paint page
 ; X       = DDSSC(DDSSC) node
 ; DDS3LIN = paint bottom line
 ;
 S DDS3P=$P(X,U),DDS3UL=$P(X,U,2),DDS3LR=$P(X,U,3)
 I DDS3UL="" W $P(DDGLCLR,DDGLDEL,2)
 E  D ^DDSBOX(DDS3UL,DDS3LR)
 ;
 ;Write caps in "X" nodes
 D CAP^DDSR1
 ;
 ;Paint data & exec caps
 ;Hdr blk
 S DDS3B=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2)
 D:DDS3B]"" DB(DDS3P,DDS3B)
 ;
 ;Other blks
 S DDS3BO="" F  S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO  S DDS3B=$O(^(DDS3BO,"")) Q:'DDS3B  D DB(DDS3P,DDS3B)
 K DDS3B,DDS3BO
 ;
 I DDS3LIN D
 . S DDSH=1,DX=0,DY=DDSHBX X IOXY W $TR($J("",IOM-1)," ","_")
 . I DDS3UL]"" S DY=DY+1 X IOXY W $P(DDGLCLR,DDGLDEL,3)
 K DDS3P,DDS3UL,DDS3LR
 Q
 ;
DB(DDS3P,DDS3B) ;Paint data
 K @DDSREFT@("XCAP",DDS3P,DDS3B)
 S DDS3=@DDSREFS@(DDS3P,DDS3B)
 S DDS3FN="F"_$P(DDS3,U,3),DDS3REP=$P(DDS3,U,7),DDS3PTB=$P(DDS3,U,8)
 K DDS3
 ;
 I $G(DDS3REP)'>1 D
 . N DIE
 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B))
 . S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL"))
 . S DDS3DDO=0
 . F  S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO  S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB)
 . K DDS3C,DDS3DA,DDS3DDO
 E  D DMULT(DDS3P,DDS3B,DDS3FN)
 ;
 K DDS3FN,DDS3PTB,DDS3REP
 Q
 ;
DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines
 N X,DIE
 S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U)
 I 'DDS3PDA D
 . S X="",DDS3STL=1
 . S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10)
 E  D
 . S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA)
 . S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9)
 S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL"))
 ;
 F DDS3LN=1:1:DDS3NREP D
 . S DDS3SN=DDS3LN+DDS3STL-1
 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN))
 . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ")
 . S:DDS3LN=DDS3REP DDS3MORE=$S($D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2:"+",1:" ")
 . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,$G(DDS3MORE),DDS3SEL)
 . K DDS3MORE
 ;
 K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL
 Q
 ;
DMULTN(DDS3P,DDS3B,DDS3PDA,DDS3REP,DDS3LN) ;Paint lines from DDS3LN
 S DDS3FN="F"_$P(@DDSREFS@(DDS3P,DDS3B),U,3)
 S DDS3STL=$P(@DDSREFT@(DDS3P,DDS3B,DDS3PDA),U,3),DDS3SEL=$P(^(DDS3PDA),U,9)
 F DDS3LN=DDS3LN:1:DDS3REP D
 . S DDS3SN=DDS3LN+DDS3STL-1
 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN))
 . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ")
 . S:DDS3LN=DDS3REP DDS3MORE=$S($D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2:"+",1:" ")
 . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,$G(DDS3MORE),DDS3SEL)
 . K DDS3MORE
 K DDS3DA,DDS3FN,DDS3LN,DDS3SEL,DDS3SN,DDS3STL
 Q
 ;
DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3MORE,DDS3SEL) ;Paint 1 line
 S DDS3DDO=0
 F  S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO  S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D
 . S $P(DDS3C,U)=$P(DDS3C,U)+DDS3LN-1
 . S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+DDS3LN-1
 . I $D(DDS3MORE),DDS3SEL=DDS3DDO,$P(DDS3C,U) D
 .. S DY=+DDS3C,DX=$P(DDS3C,U,2)-1 Q:DX<0
 .. X IOXY W DDS3MORE
 . D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN)
 K DDS3C,DDS3DDO
 Q
 ;
DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ;
 ;Paint field
 N DDS3FLD,DDS3LEN,DDSX
 D:$P(DDS3C,U,5)]"" XCAP
 ;
 S DY=+DDS3C,DX=$P(DDS3C,U,2)
 S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4)
 ;
 ;Computed flds
 I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA)
 ;
 ;Form only flds
 Q:DDS3FLD=""
 I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0"
 ;
 ;External form
 S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D")))
 I $G(DDSX)]""!$G(DDS3FLG) D
 . S:$D(DDSX)[0 DDSX=""
 . X IOXY
 . I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX))
 . E  S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN)
 . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
 Q
 ;
XCAP ;Paint exec caps
 N Y,DDSLN,DDSSN
 I 'DDS3DA N DA,D0 S (DA,D0)=""
 ;
 I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2
 I  N DA,@$$D0^DDS(DDSDL)
 I  D BLDDA^DDS(DDS3DA)
 ;
 S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5)
 S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ
 S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ
 ;
 S:$D(DDS3LN) DDSLN=DDS3LN
 S:$D(DDS3SN) DDSSN=DDS3SN
 ;
 X DDS3L01 G:$G(Y)="" XCAPQ
 S DDS3CAP=Y
 ;
 I DDS3TP="e","^2^3^"_(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D
 . S Y=$TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 . S @DDSREFT@("XCAP",DDS3P,DDS3B,Y,DDS3DDO)=""
 ;
 S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6)
 S DDS3CAP=DDS3CAP_$P(DDS3C,U,7)
 S:$P(DDS3C,U,8) DDS3CAP=$P(DDGLVID,DDGLDEL,4)_DDS3CAP_$P(DDGLVID,DDGLDEL,10)
 X IOXY W DDS3CAP
XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP
 Q

DDSR1
DDSR1 ;SFISC/MKO-PAINT ;08:09 AM  20 May 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
CAP ;Write captions in "X" nodes
 W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,2)
 ;
 S DY=""
 F  S DY=$O(@DDSREFS@("X",DDS3P,DY)) Q:DY=""  S DX=$O(^(DY,"")),DDS3CAP=^(DX) D:$D(^(DX))=11  X IOXY W DDS3CAP
 . N A,C,C1,C2,P,PC,V,X
 . Q:'$D(@DDSREFS@("X",DDS3P,DY,DX,"A"))  S A=^("A")
 . S X=DDS3CAP,DDS3CAP="",P=1
 . F PC=1:1:$L(A,U) S C=$P(A,U,PC) D:C]""
 .. S C1=$P(C,";"),C2=$P(C,";",2)
 .. S V=$S($P(C,";",3)="U":$P(DDGLVID,DDGLDEL,4),1:"")
 .. S DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)_$P(DDGLVID,DDGLDEL,10)_$S($D(DDGLVAN):$P(DDGLVID,DDGLDEL,2),1:"")
 .. S P=C2+1
 . S DDS3CAP=DDS3CAP_$E(X,P,999)
 ;
 W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,10)
 K DDS3CAP
 Q

DDSRSEL
DDSRSEL ;SFISC/MKO-RECORD SELECTION ;08:14 AM  31 Jul 1995
 ;;21.0;VA FileMan;**4,13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PG ;Called from:
 ;  DDS01 when user presses SELECT
 ;  FIRSTPG^DDS0 if no DA was passed in.
 ;
 ;Returns (if there is a record selection page and we're not in
 ;a multiple)
 ; DDSPG  = Record selection page #
 ; DDACT  = "NP"
 ; DDSSEL = 1 (undefined if no record selection page)
 ;
 N P,P1 K DDSSEL
 I $D(DDSSC),$P(DDSSC(DDSSC),U,4) Q
 ;
 S P="",P1=$P($G(^DIST(.403,+DDS,21)),U)
 I P1]"" D
 . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
 . I P]"",$D(^DIST(.403,+DDS,40,P,0))[0 S P=""
 ;
 I P]"" D
 . I $G(DDO),$G(DDSDN)=1 D
 .. D ERR3^DDS3
 . E  S DDSPG=P,DDACT="NP",DDSSEL=1
 Q
 ;
GDA ;Called from DDS
 ;After a record selection page is closed get the DA from
 ;the first field on the page.
 N DDSANS,DDSREC,Y
 S DDSANS=""
 S DDSREC=$$GET^DDSVALF(1,1,$P(^DIST(.403,+DDS,21),U))
 ;
 K DA,DDSDAORG
 S DDSDA=DDSDASV,DDSDL=DDSDLSV
 D BLDDA^DDS(DDSDA)
 M DDSDAORG=DDSORGSV
 ;
 I 'DDSREC,DA S DDSREC=DA
 E  I DDSREC,DDSREC'=DA D
 . I DA D  Q:DDSREC=DA
 .. S DDSANS=$$ASKSAVE
 .. I DDSANS="R" S DDSREC=DA
 .. E  I DDSANS="S" D
 ... D ^DDS4
 ... S:Y'=1 DDSREC=DA
 . ;
 . S DA=DDSREC
 . D REC^DDS0(DDP,.DA)
 . ;
 . I $G(DIERR) D  Q
 .. D ERR^DDSMSG H 2
 .. S DA=+$G(DDSDASV),DDACT="N"
 .. D REC^DDS0(DDP,.DA)
 . ;
 . S DDACT="N"
 . I DDSSC=1 D FRSTPG^DDS0(DDS,.DA,$G(DDSPAGE))
 . D CLRDAT,UNLOCK
 ;
 K DDSSEL,DDSDASV,DDSDASV,DDSDLSV,DDSORGSV
 Q
 ;
ASKSAVE() ;
 ;Ask user whether to save the previous record
 N X,Y
 D:DDM CLRMSG^DDS
 S DDM=1
 ;
 K DIR S DIR(0)="SM^S:SAVE;D:DISCARD;R:RETURN"
 S DIR("A",1)="  NOTE:  You must Save or Discard all edits to the"
 S DIR("A",2)="         previous record before editing the next record."
 S DIR("A",3)=" "
 S DIR("A")="Save, Discard, or Return (S/D/R)"
 S DIR("B")="SAVE"
 ;
 S DIR("?",1)="Enter 'S' to save or 'D' to discard."
 S DIR("?")="Enter 'R' or '^' to return to previous record."
 ;
 S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^7^"_(IOSL-4)_"^0"
 D ^DIR
 I $D(DIRUT) S Y="R"
 E  I X="SAVE" S Y="S"
 K DIR,DIROUT,DIRUT,DTOUT,DUOUT
 Q Y
 ;
CLRDAT ;Clear all data values from @DDSREFT
 N F,P
 S P=0 F  S P=$O(@DDSREFT@(P)) Q:'P  K @DDSREFT@(P)
 S F="F" F  S F=$O(@DDSREFT@(F)) Q:$E(F)'="F"  K @DDSREFT@(F)
 Q
 ;
UNLOCK ;Unlock all records locked
 Q:'$D(^TMP("DDS",$J,"LOCK"))
 N I S I=""
 F  S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I=""  D
 . I I'=(DIE_DA_")") L -@I K ^TMP("DDS",$J,"LOCK",I)
 Q

DDSRUN
DDSRUN ;SFISC/MKO-RUN A FORM ;02:30 PM  28 Jul 1995
 ;;21.0;VA FileMan;**6,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;Select file (DDSFILE)
 S DDS1="RUN FORM FROM" D W^DICRW K DDS1 G:Y<0 RUNQ
 G:'$D(@(DIC_"0)")) RUNQ
 K DDSFILE S DDSFILE=+Y
 ;
 ;Select form (DDSRUNDR)
 K DIC
 S DIC=.403,DIC(0)="QEA",D="F"_+Y
 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
 I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,2)) I DUZ(0)[$E($P(^(0),U,2),DDSI) Q"
 W ! D IX^DIC K DIC,D G:Y<0 RUNQ
 S DDSRUNDR=+Y
 ;
 I '$$COMPILED^DDS0(DDSRUNDR) D EN^DDSZ(DDSRUNDR) G:$G(DIERR) RUNQ
 ;
 ;Select page (DDSPAGE)
 K DIR
 S DIR(0)="NOA^1:999.9:1"
 S DIR("A")="Enter number of first page: ",DIR("B")=1
 W ! D ^DIR K DIR G:$D(DIRUT) RUNQ
 K DDSPAGE S:Y'=1 DDSPAGE=Y
 ;
REC ;Select record (DA)
 K DA
 I '$P(^DIST(.403,DDSRUNDR,0),U,10) D  G:DA<0 RUNQ
 . S DIC=DDSFILE,DIC(0)="QEALM"
 . W ! D ^DIC K DIC
 . S DA=+Y
 K D,DIC,X,Y
 ;
 ;Invoke form
 K DR S DR=DDSRUNDR D ^DDS G:$D(DA) REC
 ;
RUNQ ;Clean up and quit
 I $D(DIERR) W !,$C(7) D MSG^DIALOG("BW")
 K D,DIC,X,Y
 K DDSFILE,DDSPAGE,DDSRUNDR,DA,DR
 K DIRUT,DTOUT,DUOUT
 Q

DDSSTK
DDSSTK ;SFISC/MKO-STACK CONTEXT, GO TO A NEW PAGE ;08:23 AM  1 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N DDO
 N DDSBK,DDSDN,DDSFLD,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
 ;
 I DDSSTACK?1"`".E D
 . S DDSSTACK=+$E(DDSSTACK,2,999)
 E  I DDSSTACK=+$P(DDSSTACK,"E") D
 . S DDSSTACK=+$O(^DIST(.403,+DDS,40,"B",DDSSTACK,""))
 E  D
 . S DDSSTACK=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(DDSSTACK),""))
 ;
 I 'DDSSTACK!($D(^DIST(.403,+DDS,40,+$G(DDSSTACK),0))[0) D  Q
 . K DDSSTACK,DDSBR
 ;
 N DDSDAORG,DDSDLORG,DDSFLORG,DDSPG
 N:'$P(^DIST(.403,+DDS,40,+$G(DDSSTACK),0),U,6) DDSSC
 ;
 S DDSPG=DDSSTACK
 K DDSSTACK,DDSBR
 ;
 S DDSDLORG=DDSDL,DDSDAORG=DA
 F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI)
 K DDSI
 ;
 S DDSSTK=1
 D PROC^DDS
 Q
 ;
UPCASE(X) ;
 ;Return X in uppercase
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDSU
DDSU ;SFISC/MLH-PROCESS HELP ;12:53 PM  25 May 1995
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LIST ;
 D FM:'$D(DDS),SC:$D(DDS)
 Q
 ;
SC ;Screen Help
 N A0,A1,A2,A3,A4,A5,A6,DDSB1,X,Y
 K DTOUT,DUOUT
 ;
 W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM")
 I $D(DDQ)#2,DDQ>DDSHBX!$D(DDSID) S DY=$P(DDQ,U),DX=$P(DDQ,U,2)
 E  D CLRMSG^DDS S DY=DDSHBX
 X DDXY
 ;
 S:$G(DDD,5)=5 DDD=1
 S:$D(DDO) DDSB1=DDO
 S DDM=1,DDO=.5
 S (A0,DIY,X)="",A1=0,A5=$S(DDD=2:$O(DS(0)),1:$O(DDH(A0)))
 K A2,DDSQ
 ;
 F  D SC1 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)
 ;
 I $D(DDSB1) S:DDO<1 DDO=DDSB1
 E  K DDO
 ;
 S %=0
 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX
 S:DDQ>DDSHBX DDM=1
 I $D(A2) K DDD,DDH,DDQ S %=A2 S:%'=1 DDSQ=1 D CLRMSG^DDS G QQ
 I $D(DDC),DDC'<0 D SV
 E  K DDD,DDH S DDSQ=1
 ;
QQ S A0=$X S X=0 X ^%ZOSF("RM") W $P(DDGLVID,DDGLDEL,8) S $X=A0
 Q
 ;
SC1 S A6=A0,A0=$O(DDH(A0)) S:A6="" A6=A0-1
 I 'A0,DDD Q:DDD=1  Q:DD<DS
 ;
 S A4=$O(DDH(+A0,""))
 I A4'="X"!(DY'>DDSHBX) S DY=DY+1 X DDXY
 I A4="E" D SC2 Q
 ;
 I $Y'<(IOSL-1)!'A0 D SC2 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)  S DY=DDSHBX+1,DX=0 X DDXY
 Q:A4=""
 ;
 D WR
 ;
 I $Y'<(IOSL-1),'$D(DTOUT),'$D(DUOUT) D  Q
 . W ! D SC2
 . W $P(DDGLVID,DDGLDEL,8) S X=0 X ^%ZOSF("RM") D REFRESH^DDSUTL
 . W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM")
 . S DX=0,DY=DDSHBX X DDXY
 ;
 S DY=$Y,DX=0
 Q
 ;
SC2 S DX=0,DY=IOSL-1 X DDXY
 W $S(DDD=1:$$EZBLD^DIALOG(8053),1:$$EZBLD^DIALOG(8081,A5_"-"_A6))_$P(DDGLCLR,DDGLDEL)
 ;
 R X:DTIME E  S DTOUT=1 K DDC G Q2
 I X?1."^" S DUOUT=1,X=U K DDC G Q2
 ;
 I X]"",X<A5!(X>A6) W $C(7) G SC2
 E  I X S:DDD["J" DDO=$O(DDH(X,"")) K DDC
 D CLRMSG^DDS
 S DDM=1
 ;
Q2 S DIY=X,DY=DDSHBX
 Q
 ;
ASK W $P(A4,U,2)_$S(%'>2:"? ",1:"")_$S(%>0&(%<3):$P($$EZBLD^DIALOG(7001),U,%)_"// ",1:"")_$P(DDGLCLR,DDGLDEL)
 S A2=0
 R X:$G(DTIME,300) E  S DTOUT=1,A2=-1 Q
 ;
 I %>2 S A2=X Q
 ;
 N %1 S %1=$$PRS^DIALOGU(7001,X) S:%1>0 X=$E($P(%1,U,2))
 K %1
 ;
 I "YyNn^"'[X W $C(7) X DDXY G ASK
 I X]"","^Nn"[X S A2=2 K DDC Q
 S:"Yy"[X A2=1
 S:X=""&(%]"") A2=+%
 S DDD=1
 Q
 ;
SV ;Kill DDH array, but save the "ID" nodes and DDH itself
 K A1,A2
 S:$D(DDH("ID")) A1=DDH("ID")
 S:$D(DDH("ID",1)) A2=DDH("ID",1)
 K DDH S DDH=0
 S:$D(A1) DDH("ID")=A1
 S:$D(A2) DDH("ID",1)=A2
 Q
 ;
FM ;FileMan help - Non screen
 N A0,A1,A2,A3,A4,DDSDIW,DDSDIY,Y
 S A0=""
 F  S A0=$O(DDH(A0)) Q:'A0  S DDSDIW=$X,DDSDIY=$Y D W I $G(DDD)>2,DDSDIW-$X!(DDSDIY-$Y) D STP Q:$D(DTOUT)
 ;
Q I '$D(DTOUT) D SV S DDH=0
 E  K DDH K:'DTOUT DTOUT
 Q
 ;
STP I DD+DIY'>79 W ?DD S DD=DD+DIY Q
 ;
T W !?3 S DD=DIY+3
 I $Y>DIZ!'$Y D
 . R "'^' TO STOP: ",%Y:$G(DTIME,300)
 . E  S DTOUT=1 K DDD
 . W *13,$J("",15),*13 Q:$D(DTOUT)
 . I %Y[U S DTOUT=0 K DDD
 . D Y W ?3
 Q
 ;
W S A4=$O(DDH(A0,"")) Q:A4=""  Q:DDH(A0,A4)=""
 W:'$D(DDD) !
 I $G(DDD)=3,A4["T" K DDD
 ;
WR I A4["X" D  Q
 . N DDD,DIY,DDSXEC
 . S DDSXEC=DDH(A0,A4)
 . N DDH
 . I $D(DDS) N DDSID S DDSID=1
 . X DDSXEC
 ;
 I A4["Q" D  Q
 . S A4=DDH(A0,A4),%=$P(A4,U,1)
 . I $D(DDS) D ASK Q
 . W $P(A4,U,2)
 . D YN^DICN
 ;
 I A4["T" D  Q
 . I DDH(A0,A4)[$C(0) D
 .. S DX=$L(DDH(A0,A4),$C(0))-1
 .. X DDXY
 .. S DDH(A0,A4)=$TR(DDH(A0,A4),$C(0),"")
 . W DDH(A0,A4)
 ;
 I '$D(DDS),DDD'["J",A4'=+A4 Q
 I $D(DDS),DDD=2!(DDD["J") W A0,?7
 ;
 W DDH(A0,A4)
 D:$D(DDH("ID"))
 . N DDD,DIY,DDSID
 . S DDSID=DDH("ID")
 . S:$D(DDH("ID",1))#2 DDSID(1)=DDH("ID",1)
 . N DDH
 . S:$D(DDSID(1))#2 DDH("ID",1)=DDSID(1) K DDSID(1)
 . S Y=A4
 . X DDSID
 Q
 ;
Y D:'$D(DISYS) OS^DII
 S $X=0,$Y=0
 S DIZ=$S($D(DILN)&'$D(DIR0):DILN,1:21)
 Q
 ;
Z D Y,T
 Q
 ;
H S:'$D(A1) A1="T"
 S DDH=$G(DDH)+1,DDH(DDH,A1)=DST
 K A1,DST
 D SC
 Q
 ;#8053  Press 'RETURN' to continue...
 ;#8081  Choose |from-to| or '^'...
 ;#7001  Yes^No

DDSUTL
DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM  25 Jul 1995
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
MSG(TXT) ;
 ;Data validation messages
 D PROC(.TXT,$NA(@DDSREFT@("MSG")))
 Q
 ;
HLP(TXT) ;
 ;Help box messages
 D PROC(.TXT,$NA(@DDSREFT@("HLP")))
 Q
PROC(TXT,GLB) ;
 ;Put text into global
 N CNT,I
 S CNT=$G(@GLB)
 I $D(TXT)<9 S CNT=CNT+1,@GLB@(CNT)=TXT
 E  S I="" F CNT=CNT:1 S I=$O(TXT(I)) Q:I=""  S @GLB@(CNT+1)=TXT(I)
 S @GLB=CNT
 Q
 ;
REFRESH ;Refresh the screen
 G R^DDSR
 ;
MLOAD(DDSIEN) ;Load subrecords for current multiple
 G MLOAD^DDSM1
 ;
MDEL(DDSIEN) ;Delete subrecords for current multiple
 G MDEL^DDSM1
 ;
UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute
 S:$D(DDSVAL)[0 DDSVAL=""
 D SETATT(4)
 Q
 ;
REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute
 S:$D(DDSVAL)[0 DDSVAL=""
 D SETATT(1)
 Q
 ;
 ;
SETATT(DDSUPC) ;Set attribute node, piece DDSUPC
 N DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP
 I $D(DDSPG)[0 N DDSPG S DDSPG=""
 I $D(DDSBK)[0 N DDSBK S DDSBK=""
 S DDSP=$$GETFLD^DDSLIB(DDSF,$G(DDSB),$G(DDSP),+DDS,DDSPG,DDSBK)
 I $G(DIERR) D ERR^DDSMSG Q
 ;
 S DDSF=$P(DDSP,","),DDSB=$P(DDSP,",",2),DDSP=$P(DDSP,",",3)
 ;
 S DDSUDDP=+$P($G(^DIST(.404,DDSB,0)),U,2)
 I DDSUDDP,$G(DDSUDA)]"" N DDSDA S DDSDA=DDSUDA
 E  I DDSUDDP,DDSB'=DDSBK N DDSDA D GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA)
 ;
 S DDSUTP=$P($G(^DIST(.404,DDSB,40,DDSF,0)),U,3) S:'DDSUTP DDSUTP=3
 I DDSUTP=2 D
 . S DDSUFLD=DDSF_","_DDSB
 . S DDSUDDP=0
 E  I DDSUTP=3 D  Q:'DDSUFLD
 . S DDSUFLD=$P($G(^DIST(.404,DDSB,40,DDSF,1)),U)
 E  Q
 ;
 S DDSOVAL=$P($G(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC)
 Q:DDSVAL=DDSOVAL
 S $P(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL
 Q
 ;
ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ;
 ;Add an entry as part of a transaction
 ;DDSL=1 means don't lock
 ;
 N %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR
 N DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I
 K DIERR,^TMP("DIERR",$J)
 K:'$G(DINUM) DINUM
 S:$G(DDSDIC0)="" DDSDIC0="L"
 S DIC(0)=DDSDIC0,Y=-1
 S:$G(DDSDR)]"" DIC("DR")=DDSDR
 S DIC=$$ROOT^DILFD(DDSFIL,.DA),DDSDIC=$$CREF^DIQGU(DIC)
 ;
 I $D(@DDSDIC@(0))[0 D  Q:$G(DIC("P"))=""
 . S DDSUP=$G(^DD(DDSFIL,0,"UP")) Q:'DDSUP
 . S DDSFD=$O(^DD(DDSUP,"SB",DDSFIL,"")) Q:'DDSFD
 . S DIC("P")=$P($G(^DD(DDSUP,DDSFD,0)),U,2)
 ;
 I DDSDIC0'["E",$$REQID(DDSFIL,.DDSREQ) D  Q:$G(DIERR)
 . N F
 . S F=""
 . F  S F=$O(DDSREQ(F)) Q:'F  I $G(DIC("DR"))'[(F_"///") D BLD^DIALOG(3031,"ADD^DDSUTL") Q
 ;
 D FILE^DICN K DTOUT,DUOUT Q:Y=-1!'$D(DDS)
 ;
 I '$G(DDSL) D
 . N I,L,R
 . S L=1,R=DIC_DA_","
 . F I=$L(R,",")-1:-1:1 I $D(^TMP("DDS",$J,"LOCK",$P(R,",",1,I)_")"))#2 S L=0 Q
 . I L,$D(^TMP("DDS",$J,"LOCK",$P(R,"(")))#2 S L=0
 . I L L +@(DIC_+Y_")"):0 S ^TMP("DDS",$J,"LOCK",DIC_+Y_")")=""
 ;
 S DDSDA=+Y_","
 F I=1:1 Q:$D(DA(I))[0  S DDSDA=DDSDA_DA(I)_","
 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIC
 Q
 ;
REQID(FIL,REQ) ;
 ;Get list of required identifiers into DDSREQ
 N F
 K REQ
 S F="" F  S F=$O(^DD(FIL,0,"ID",F)) Q:F'=+$P(F,"E")  D
 . S:$P($G(^DD(FIL,F,0)),U,2)["R" REQ(F)=""
 Q $D(REQ)>0
 ;
DESTROY(PG) ;Destroy all data for page PG
 N P,B,F,IENS,TP,FIL,FLD
 S P=$O(^DIST(.403,+DDS,40,"B",PG,"")) Q:'P
 S B=0 F  S B=$O(^DIST(.403,+DDS,40,P,40,B)) Q:'B  D
 . Q:'$D(^DIST(.403,+DDS,40,P,40,B,0))
 . Q:'$D(^DIST(.404,B,0))  S FIL=$P(^(0),U,2)
 . S F=0 F  S F=$O(^DIST(.404,B,40,F)) Q:'F  D
 .. Q:'$D(^DIST(.404,B,40,F,0))  S TP=$P(^(0),U,3)
 .. S:'TP TP=3
 .. ;
 .. I TP=3 S FF="F"_FIL,FLD=$G(^DIST(.404,B,40,F,1)) Q:FLD?."^"
 .. E  I TP=2 S FF="F0",FLD=F_","_B
 .. E  Q
 .. ;
 .. S IENS=" "
 .. F  S IENS=$O(@DDSREFT@(FF,IENS)) Q:IENS=""  K ^(IENS,FLD)
 ;
 K @DDSREFT@(P),@DDSREFT@("XCAP",P)
 Q
 ;
 ;
DDSDA(DA,DL,DDSDA) ;Determine DDSDA
 ;
 N I
 I DA="" S DDSDA="" Q
 S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_","
 Q

DDSVAL
DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;9:38 AM  29 Aug 1995
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field
 N DDP,DIE,DDSANS,DDSTMP,X
 N DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR
 ;
 S DDSANS=""
 I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I"
 ;
 D GDIE() G:$G(DIERR) GETQ G:'$G(DDSVDA) GETQ
 ;
 I DDSFLD[":",$$FIND^DDSLIB(DDSFLD,":") D  G GETQ
 . S DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM)
 ;
 S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) GETQ
 ;
 S:$D(DDSREFT)#2 DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
 I $D(DDS),$D(DDSREFT)#2,$D(@DDSTMP@("D")) D
 . I $D(@DDSTMP@("M")),'^("M") D  Q
 .. S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSVDA,DDSFLD))
 .. M @DDSANS=@DDSTMP@("D")
 . S DDSANS=$G(@DDSTMP@("D")) I DDSPARM["E",$D(^("X"))#2 S DDSANS=^("X")
 E  D
 . D GNDPC Q:$G(DIERR)
 . I DDSVPC=0,DDSVDV["W" D GETWP^DDSVALM Q
 . S DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC)
 . I DDSPARM["E" S DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS)
 ;
GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVAL")
 Q DDSANS
 ;
PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field
 N DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE
 N DIERR
 ;
 S:$D(DDSVAL)[0 DDSVAL=""
 I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E"
 ;
 D GDIE($D(DDS)#2) G:$G(DIERR) PUTQ G:'$G(DDSVDA) PUTQ
 S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) PUTQ
 I DDSFLD=.01,"@"[DDSVAL D BLD^DIALOG(3086) G PUTQ
 ;
 S DDSV0=^DD(DDP,DDSFLD,0),DDSV02=$P(DDSV0,U,2)
 I +DDSV02 D
 . D MULT^DDSVALM
 E  D VALPUT
 ;
PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVAL")
 Q
 ;
VALPUT ;Validate and put
 N DDSVY
 I DDSPARM["E" D
 . D VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY)
 E  D
 . D AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02)
 Q:$G(DIERR)
 I DDSVY=DDSVY(0),'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X")) K DDSVY(0)
 ;
 I $D(DDS) D
 . S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) ^("GL")=DIE
 . D UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY)
 . S DDSCHG=1
 E  D
 . N DDSFDA
 . S DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY
 . D FILE^DIE("","DDSFDA")
 Q
 ;
UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint
 N DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL
 S (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (EXT,^("X"))=Y(0)
 ;
 D:FLD=.01
 . S PAGE=0 F  S PAGE=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE)) Q:'PAGE  D
 .. S BK=0 F  S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK)) Q:'BK  D
 ... D:$P($G(@DDSREFS@(PAGE,BK)),U,8)
 .... N DDSPTB S DDSPTB=$G(@DDSREFS@(PAGE,BK,"PTB"))
 .... D:DDSPTB]"" RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA)
 ;
 S BK=0 F  S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK)) Q:'BK  D
 . S DDO=0 F  S DDO=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO)) Q:'DDO  D
 .. S LEN=$G(@DDSREFS@(PG,BK,DDO,"D")) Q:LEN=""
 .. S DY=+LEN,DX=$P(LEN,U,2),RJ=$P(LEN,U,10),LEN=$P(LEN,U,3)
 .. S REP=$P($G(@DDSREFS@(PG,BK)),U,7)
 .. I $G(REP) D  Q:DY=""
 ... N SN,PDA,OFS
 ... S PDA=$G(@DDSREFT@(PG,BK)) I 'PDA S DY="" Q
 ... S REP=$P($G(@DDSREFT@(PG,BK,PDA)),U,2,999) I REP="" S DY="" Q
 ... S SN=$G(@DDSREFT@(PG,BK,PDA,"B",DDSVDA)) I 'SN S DY="" Q
 ... S OFS=SN-$P(REP,U,2)
 ... I OFS'<0,OFS<$P(REP,U,5) S DY=DY+OFS
 ... E  S DY=""
 .. S VAL=$P(DDGLVID,DDGLDEL)_$E(EXT,1,LEN)_$P(DDGLVID,DDGLDEL,10)
 .. X IOXY
 .. W $S(RJ:$J("",LEN-$L(EXT))_VAL,1:VAL_$J("",LEN-$L(EXT)))
 ;
 D:$D(@DDSREFS@("PT",DDP,FLD)) RPB^DDS7(DDP,FLD,PG)
 D:$D(@DDSREFS@("COMP",DDP,FLD,PG)) RPCF^DDSCOMP(PG)
 Q
 ;
GDIE(DDSVL) ;In:
 ;  DDSFILE = File # or root
 ;  DA      = Record array
 ;  DDSVL   = Flag to lock record
 ;Returns:
 ;  DIE    = Global root of file
 ;  DDP    = File #
 ;  DDSVDL = Level #
 ;  DDSVDA = DA,DA(1),...,
 S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2))
 I DDP=0 D BLD^DIALOG(202,"file") Q
 D GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$G(DDSVL))
 Q
 ;
GNDPC ;In:
 ;  DDP    = File #
 ;  DDSFLD = Field #
 ;Returns:
 ;  DDSVDDL0 = 0 node of DD
 ;  DDSVND   = Node where data resides
 ;  DDSVPC   = Piece where data resides
 ;  DDSVDV   = Field specifications
 ;  X        = Pointed to file root or set of codes
 I $G(DDSFLD)="" D BLD^DIALOG(202,"field") Q
 S DDSVDDL0=$G(^DD(DDP,DDSFLD,0))
 I DDSVDDL0?."^" D  Q
 . N I,E
 . S (I("FILE"),E("FILE"))=DDP,I(1)="#"_DDSFLD,E("FIELD")=DDSFLD
 . D BLD^DIALOG(501,.I,.E)
 ;
 S DDSVPC=$P(DDSVDDL0,U,4)
 S DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2)
 S DDSVDV=$P(DDSVDDL0,U,2),X=$P(DDSVDDL0,U,3)
 ;
 N P S P("FILE")=DDP,P("FIELD")=DDSFLD
 I DDSVPC=" " D
 . D BLD^DIALOG(520,"computed",.P)
 I DDSVPC=0 D
 . S DDSVDV=+DDSVDV_$P($G(^DD(+DDSVDV,.01,0)),U,2)
 . D:DDSVDV'["W" BLD^DIALOG(520,"multiple",.P)
 Q
 ;
GVAL(DIE,DA,ND,PC) ;Get value
 N LN,Y
 S LN=$G(@(DIE_"DA,ND)"))
 I $E(PC)'="E" S Y=$P(LN,U,PC)
 E  S Y=$E(LN,+$E(PC,2,999),$P(PC,",",2)) S:Y?." " Y=""
 Q Y
 ;
FIELD(DDP,FLD) ;Get field number
 N F,P
 S:$E(FLD)="""" FLD=$$UQT^DDSLIB($E(FLD,1,$$AFTQ^DDSLIB(FLD)-1))
 ;
 S F=FLD,P("FILE")=DDP
 I FLD'=+$P(FLD,"E") D  Q:$G(DIERR) ""
 . S F=$O(^DD(DDP,"B",FLD,""))
 . I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
 ;
 I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
 Q F

DDSVALF
DDSVALF ;SFISC/MKO-GET,PUT VALUES FOR FORM ONLY FIELDS ;9:38 AM  29 Aug 1995
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
GET(DDSVFD,DDSVBK,DDSVPG,DDSPARM,DDSVDA) ;Get value
 ;In:  DDSPG = Current page
 ;     DDSBK = Current block
 ;     DDSPARM = "I" : internal, "E" : external form
 ;
 N DDSANS,DDSFLD,DDSVDDP,DIERR
 I $D(DDSPG)[0 N DDSPG S DDSPG=0
 I $D(DDSBK)[0 N DDSBK S DDSBK=0
 S DDSANS=""
 I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I"
 ;
 S DDSFLD=$P($$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,$G(DDSPG),$G(DDSBK),"F"),",",1,2)
 G:$G(DIERR) GETQ
 ;
 S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2)
 ;
 S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2)
 I DDSVDDP,$G(DDSVDA)]"" N DDSDA S DDSDA=DDSVDA
 E  I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
 ;
 I $D(@DDSREFT@("F0",DDSDA,DDSFLD,"D"))#2 S DDSANS=^("D") S:DDSPARM["E"&($D(^("X"))#2) DDSANS=^("X") G GETQ
 ;
 I "013"[$P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3) D BLD^DIALOG(520,"DD or caption-only") G GETQ
 ;
 ;Form-only fields
 I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=2 D  G:$G(DIERR) GETQ
 . I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,20)),U)="" D  Q
 .. N P S P(1)="READ TYPE",P(2)="FIELD multiple of the BLOCK"
 .. D BLD^DIALOG(3011,.P)
 . D:$D(^DIST(.404,DDSVBK,40,DDSVFD,3))#2 DEF(^(3),$G(^(3.1)),.DDSANS)
 . S (@DDSREFT@("F0",DDSDA,DDSFLD,"D"),^("O"))=DDSANS
 . I DDSANS]"" D
 .. S:$D(DDSANS(0)) (DDSANS,@DDSREFT@("F0",DDSDA,DDSFLD,"X"))=$S($D(DDSANS(0,0))#2:DDSANS(0,0),1:DDSANS(0))
 .. S $P(@DDSREFT@("F0",DDSDA,DDSFLD,"F"),U)=3,DDSCHG=1
 ;
 ;Computed fields
 E  S:$P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=4 DDSANS=$$VAL^DDSCOMP(DDSVFD,DDSVBK,DDSDA)
 ;
GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVALF")
 Q DDSANS
 ;
PUT(DDSVFD,DDSVBK,DDSVPG,DDSVAL,DDSPARM,DDSVDA) ;Put value
 N DIR,X,Y
 N DDER,DDSFLD,DDSVDDP,DDSVX,DIERR
 I $D(DDSPG)[0 N DDSPG S DDSPG=0
 I $D(DDSBK)[0 N DDSBK S DDSBK=0
 S:$D(DDSVAL)[0 DDSVAL=""
 I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E"
 ;
 S DDSFLD=$$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,DDSPG,DDSBK,"F")
 G:$G(DIERR) PUTQ
 S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2),DDSVPG=$P(DDSFLD,",",3)
 S DDSFLD=$P(DDSFLD,",",1,2)
 ;
 S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2)
 I DDSVDDP,$G(DDSVDA)]"" N DDSDA S DDSDA=DDSVDA
 E  I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
 ;
 ;
 I $P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)'=2 D BLD^DIALOG(520,"DD, computed, or caption-only") G PUTQ
 ;
 S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3)
 I DDSPARM["I",$E(DIR(0))="P"!(DIR(0)?1"DD".E) D
 . N FIL,FILROOT,FLD
 . S Y=DDSVAL
 . I $E(DIR(0))="P" D
 .. S FIL=$P($P(DIR(0),U,2),":")
 .. I 'FIL S FILROOT=U_FIL,FIL=+$P($G(@(U_FIL_"0)")),U,2) Q:'FIL
 .. E  S FILROOT=$G(^DIC(FIL,0,"GL")) Q:FILROOT=""
 .. S Y(0)=$P($G(@(FILROOT_Y_",0)")),U)
 .. S Y(0)=$$EXTERNAL^DILFD(FIL,.01,"",Y(0))
 . E  D
 .. N DV,I S FIL=$P($P(DIR(0),","),U,2),FLD=$P(DIR(0),",",2)
 .. S DV=$P($G(^DD(FIL,FLD,0)),U,2)
 .. F I="O","P","V","D","S" I DV[I S Y(0)=$$EXTERNAL^DILFD(FIL,FLD,"",Y) Q
 E  D  G:$G(DDER) PUTQ
 . I DDSVAL="" D  Q
 .. N DDSVREQ
 .. S DDSVREQ=$P($G(@DDSREFT@(DDSVPG,DDSVBK,DDSVFD)),U)
 .. S:DDSVREQ]"" DDSVREQ=$P($G(^DIST(.404,DDSVBK,40,DDSVFD,4)),U)
 .. I DDSVREQ S DDER=1
 .. E  S Y=""
 . S DIR("V")="",(X,DIR("B"))=DDSVAL
 . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
 . I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D
 .. N I
 .. S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z"
 .. S $P(I,":",2)=$P(I,":",2)_"Z"
 .. S $P(DIR(0),U,2)=I
 . D ^DIR
 . I $E($P(DIR(0),U))="P" S Y=$P(Y,U)
 ;
 ;Update ^TMP
 S DDSCHG=1
 S (DDSVX,@DDSREFT@("F0",DDSDA,DDSFLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (DDSVX,^("X"))=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) I $D(^("X"))#2,Y="" S (DDSVX,^("X"))=""
 ;
 ;Repaint field if it appears on the current page
 I $D(@DDSREFS@("F0",DDSFLD,"L",DDSPG,DDSVBK,DDSVFD))#2 D
 . N DY,DX,DDSVL,DDSVRJ,DDSX,DDSVREP
 . S DDSVREP=$P($G(@DDSREFS@(DDSPG,DDSVBK)),U,7)
 . S DY=+@DDSREFS@(DDSPG,DDSVBK,DDSVFD,"D"),DX=$P(^("D"),U,2),DDSVL=$P(^("D"),U,3),DDSVRJ=$P(^("D"),U,10)
 . I $G(DDSVREP) D  Q:DY=""
 .. N DDSVSN,DDSVPDA,DDSVOFS
 .. S DDSVPDA=$G(@DDSREFT@(DDSPG,DDSVBK)) I 'DDSVPDA S DY="" Q
 .. S DDSVREP=$P($G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA)),U,2,999) I DDSVREP="" S DY="" Q
 .. S DDSVSN=$G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA,"B",DDSDA)) I 'DDSVSN S DY="" Q
 .. S DDSVOFS=DDSVSN-$P(DDSVREP,U,2)
 .. I DDSVOFS'<0,DDSVOFS<$P(DDSVREP,U,5) S DY=DY+DDSVOFS
 .. E  S DY=""
 . S DDSX=$P(DDGLVID,DDGLDEL)_$E(DDSVX,1,DDSVL)_$P(DDGLVID,DDGLDEL,10)
 . X IOXY
 . W $S(DDSVRJ:$J("",DDSVL-$L(DDSVX))_DDSX,1:DDSX_$J("",DDSVL-$L(DDSVX)))
 ;
 D
 . N DDP,DDSDA S DDP=0,DDSDA="0,"
 . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG)
 . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG)
 ;
PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVALF")
 Q
 ;
DEF(DDSLN3,DDSLN31,Y) ;Get default
 N DDER,DIR,X
 Q:DDSLN3=""
 ;
 I DDSLN3'="!M" S Y=DDSLN3
 E  I DDSLN31'?."^" X DDSLN31 S:$D(Y)[0 Y=""
 Q:Y=""
 ;
 S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3)
 S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
 S DIR("V")="",(X,DIR("B"))=Y
 D ^DIR I DDER K Y S Y=""
 ;
 I Y]"",$E($P(DIR(0),U))="P" S Y=$P(Y,U)
 Q
 ;

DDSVALM
DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM  9 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
MULT ;Put multiple or wp field
 N DDSVDIC,DDSVDV,DDSVND,DDSVPC,DDSVSUB
 S DDSVPC=$P(DDSV0,U,4),DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2)
 S DDSVSUB=+DDSV02 Q:$D(^DD(DDSVSUB,.01,0))[0
 S DDSVDV=DDSVSUB_$P(^DD(DDSVSUB,.01,0),U,2),X=$P(^(0),U,3)
 S DDSVDIC=DIE_DA_","""_DDSVND_""","
 ;
 I DDSVDV["W" D PUTWP
 I DDSVDV'["W" D PUTMULT
 Q
 ;
PUTMULT ;Put for multiples
 N DDSVRN
 S DDSVRN=$S(DDSVAL="FIRST":$O(@(DDSVDIC_"0)")),DDSVAL="LAST":$O(@(DDSVDIC_""" "")"),-1),1:+$G(DDSVAL))
 ;
 K Y S Y="",Y(0)=""
 I DDSVRN>0,$D(@(DDSVDIC_+DDSVRN_",0)"))#2 S Y(0)=$P(^(0),U) D
 . I DDSVDV["O"!(DDSVDV["P")!(DDSVDV["V")!(DDSVDV["D")!(DDSVDV["S") D
 .. S Y(0)=$$EXTERNAL^DILFD(DDSVSUB,.01,"",DDSVRN)
 . S Y=DDSVRN
 ;
 S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"M")) ^("M")=1_DDSVDIC_U_DDSVSUB
 D UPDATE^DDSVAL(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.Y)
 Q
 ;
PUTWP ;File wp field from @DDSVAL into @DDSREFT
 N DDSTMP
 S DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSDA))
 ;
 I DDSVAL]"",$D(@DDSVAL) D  Q:$G(DIERR)
 . D PUTWP^DIEFW($E("A",DDSPARM["A"),DDSVAL,$NA(@DDSTMP@(DDSFLD,"D")))
 E  K @DDSTMP@(DDSFLD,"D")
 ;
 S:$D(@DDSTMP@(DDSFLD,"M"))[0 ^("M")="0"_DDSVDIC_U_DDSVSUB
 S:$D(@DDSTMP@("GL"))[0 ^("GL")=DIE
 S (DDSCHG,@DDSTMP@(DDSFLD,"F"))=3
 Q
 ;
GETWP ;Merge wp field into ^TMP, return root in DDSANS
 N DDSGL
 S DDSGL=DIE_DA_","""_DDSVND_""","
 S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSDA,DDSFLD))
 ;
 K @DDSANS
 M:$D(@(DDSGL_"0)"))#2 @DDSANS=@($E(DDSGL,1,$L(DDSGL)-1)_")")
 Q
 ;
REL(DDP,DA,DDSFLD,DDSPARM) ;Relational syntax
 N DDSCD,DDSI,X
 D DD^DDSPTR(DDP,DDSFLD,"",.DDSCD,"",DDSPARM["I"+1)
 F DDSI=1:1:DDSCD X DDSCD(DDSI)
 Q X
 ;
ERR(DDSVEP) ;Print error messages
 Q:'$G(DIERR)
 I '$D(DDS) D MSG^DIALOG("BW") Q
 N DDSVMSG
 S DDSER=DIERR
 D BLD^DIALOG(3031,DDSVEP,"","DDSVMSG")
 D MSG^DDSMSG(DDSVMSG(1)),ERR^DDSMSG
 Q

DDSWP
DDSWP ;SFISC/MKO-WP ;08:05 AM  26 Jul 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EDIT ;Edit the word processing field
 N I
 S DDSUE=$D(DDSTP)#2!$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P(DDSU("A"),U,4))
 I DDSUE D  I $D(DIRUT) K DIRUT,DUOUT,DIROUT G EDITQ
 . D:DDM CLRMSG^DDS
 . K DIR S DIR(0)="E"
 . S DIR("A",1)="WARNING: This field is uneditable."
 . S DIR("A",2)="         Any changes made in the editor will not be saved."
 . S DIR("A",3)=""
 . S DIR("A")="Press RETURN to enter editor:"
 . S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^1^"_(IOSL-4)_"^0"
 . D ^DIR K DIR
 ;
 S DDSUTL=$NA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD))
 ;
 I $D(@DDSUTL@("F"))[0,$D(@(DDSGL_"0)"))#2 D
 . K @DDSUTL@("D")
 . M @DDSUTL@("D")=@($E(DDSGL,1,$L(DDSGL)-1)_")")
 ;
 S (DY,DX)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2)
 S DIC=$E(DDSUTL,1,$L(DDSUTL)-1)_",""D"",",DWPK=1
 S DIWESUB=$P($G(DDSU("DD")),U) K:DIWESUB="" DIWESUB
 D EN^DIWE
 K DIC,DIWESUB,DWPK
 I 'DDSUE S DDSCHG=1,@DDSUTL@("F")=1
 E  K @DDSUTL@("D")
EDITQ K DDSUE,DDSUTL
 Q
 ;
WP ;At the wp field
 S DIR(0)="FO^0:0"
 S DIR("?")="^W ""Press 'RETURN' to edit this word processing field."""
 S DIR("??")="^D HELP^DDSWP"
 D ^DIR K DIR,DUOUT,DIRUT,DIROUT
 Q
HELP ;?? help at the WP field
 S DDSFN=+$P(DDSU("M"),U,3)
 D:$G(^DD(DDSFN,.01,3))]"" MSG^DDSMSG(^(3))
 X:$G(^DD(DDSFN,.01,4))]"" ^(4)
 D:$D(^DD(DDSFN,.01,21)) WP^DDSMSG("^DD("_DDSFN_",.01,21)")
 K DDSFN
 Q

DDSZ
DDSZ ;SFISC/MKO-FORM COMPILER ;11:26 AM  16 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;Prompt, compile
 N DDSFRM,DDSDDP,DDSREFS
 N C,DIC,X,Y
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 ;
 S DIC="^DIST(.403,",DIC(0)="AEQZ"
 D ^DIC K DIC Q:Y=-1!'$D(^DIST(.403,+Y,0))
 S DDSFRM=Y,DDSDDP=$P(Y(0),U,8)
 ;
 W !!,"Compiling "_$P(Y,U,2)_" (#"_+Y_") ...",!
 D EN(DDSFRM,DDSDDP)
 I $G(DIERR) W $C(7) D MSG^DIALOG("BW")
 Q
 ;
ALL ;Compile all forms
 N DDSFRM,DDSDDP,DDSFNUM,DDSREFS
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 W:'$D(DDSQUIET) !,"Compiling all forms ...",!
 ;
 S DDSFNUM=0
 F  S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM  D
 . Q:$D(^DIST(.403,DDSFNUM,0))[0
 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U),DDSDDP=+$P(^(0),U,8)
 . S DDSREFS=$$REF^DDS0(DDSFRM)
 . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
 . D EN(DDSFRM,DDSDDP)
 . I $G(DIERR),'$D(DDSQUIET) W !,$C(7) D MSG^DIALOG("BW") W !
 Q
 ;
EN(DDSFRM,DDSDDP,DDSREFS) ;Compile a form
 N DDSDO,DDSPG,DDSNDD,DDSPGRP
 ;
 S:'$G(DDSDDP) DDSDDP=$P(^DIST(.403,+DDSFRM,0),U,8)
 S:$G(DDSREFS)="" DDSREFS=$$REF^DDS0(DDSFRM)
 K @DDSREFS
 ;
 ;Find page groups
 D PGRP^DDSZ3(+DDSFRM,.DDSPGRP)
 ;
 S DDSPG=0,(DDSDO,DDSNDD)=1
 F  S DDSPG=$O(^DIST(.403,+DDSFRM,40,DDSPG)) Q:'DDSPG  D PG(DDSFRM,DDSPG,DDSDDP,.DDSDO,.DDSNDD) Q:$G(DIERR)
 I $G(DIERR) D ERR(DDSFRM,DDSREFS) Q
 S $P(^DIST(.403,+DDSFRM,0),U,9,11)=+$G(DDSDO)_U_+$G(DDSNDD)_U_1
 Q
 ;
PG(DDSFRM,DDSPG,DDSDDP,DDSDO,DDSNDD) ;Compile a page
 ;
 Q:$D(^DIST(.403,+DDSFRM,40,DDSPG,0))[0
 D:$P($G(^DIST(.403,+DDSFRM,40,DDSPG,1)),U,2)]"" ASUB^DDSZ3(DDSPG,DDSFRM)
 ;
 ;Get page coordinates
 S DDSPX=$P(^DIST(.403,+DDSFRM,40,DDSPG,0),U,3)
 S DDSPY=$P(DDSPX,",")-1,DDSPX=$P(DDSPX,",",2)-1
 S:DDSPY<0 DDSPY=0 S:DDSPX<0 DDSPX=0
 ;
 ;Compile header block
 S DDSB=$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U,2)
 I DDSB]"" D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,"",1,"",.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END
 ;
 ;Compile all other blocks on page
 S DDSBO="" F  S DDSBO=$O(^DIST(.403,+DDSFRM,40,DDSPG,40,"AC",DDSBO)) Q:DDSBO=""  S DDSB=$O(^(DDSBO,0)) Q:'DDSB  D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,"",.DDSDO,.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END
 ;
 D:$D(DDSSCR)!$D(DDSORD) EN^DDSZ2(.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
 ;
END K DDSB,DDSBO,DDSMUL,DDSNAV,DDSORD
 K DDSP,DDSPX,DDSPY,DDSREP,DDSRNAV,DDSSCR
 Q
 ;
BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,DDSH,DDSDO,DDSNDD,DDSSCR,DDSNAV,DDSORD) ;
 ;Compile block
 ; DDSH   = 1 if header block
 ; DDSDO  = killed if any edit blocks
 ; DDSNDD = killed if any DD fields
 ;
 N DDP
 I $D(^DIST(.404,DDSB,0))[0 D BLD^DIALOG(3051,"#"_DDSB) Q
 S DDSDN=$P(^DIST(.404,DDSB,0),U,3),DDP=+$P(^(0),U,2)
 ;
 S DDSPTB=""
 S:'$G(DDSH) DDSPTB=$G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,1))
 ;
 ;Get DDSBY,DDSBX,DDSTP
 I $G(DDSH) S DDSBY=DDSPY,DDSBX=DDSPX,DDSTP="h",DDSREP=1
 E  D
 . S DDSBX=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,0),U,3),DDSTP=$P(^(0),U,4) S DDSREP=$S($G(^(2)):^(2),1:1)
 . K:DDSTP="e" DDSDO
 . S DDSBY=$P(DDSBX,",")-1,DDSBX=$P(DDSBX,",",2)-1
 . S:DDSBY<0 DDSBY=0 S:DDSBX<0 DDSBX=0
 . S DDSBY=DDSBY+DDSPY,DDSBX=DDSBX+DDSPX
 ;
 ;Set @DDSREFS@(DDSPG,DDSB)
 S @DDSREFS@(DDSPG,DDSB)=DDSBY_U_DDSBX_U_$P($G(^DIST(.404,DDSB,0)),U,2)_U_DDSDN_U_DDSTP_$S(DDSREP>1:U_U_+DDSREP,1:"")
 ;
 D:DDSPTB]"" PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB)
 D EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV)
 ;
 K DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP
 Q
 ;
DELALL ;Delete compile global for all forms
 N DDSFRM,DDSFNUM,DDSREFS
 W:'$D(DDSQUIET) !,"Deleting compiled form data ...",!
 ;
 S DDSFNUM=0
 F  S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM  D
 . Q:$D(^DIST(.403,DDSFNUM,0))[0
 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U)
 . S DDSREFS=$$REF^DDS0(DDSFRM)
 . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")"
 . D DEL(DDSFRM)
 Q
 ;
DEL(DDSFRM) ;Delete compiled global
 N DDSREFS
 S DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS
 S $P(^DIST(.403,+DDSFRM,0),U,11)=""
 Q
 ;
ERR(DDSFRM,DDSREFS) ;Print error, kill compiled global
 Q:'$G(DIERR)
 N DDSNAM
 S DDSNAM=$P(DDSFRM,U,2)
 S:DDSNAM="" DDSNAM=$P($G(^DIST(.403,+DDSFRM,0)),U)
 D BLD^DIALOG(3002,DDSNAM)
 S $P(^DIST(.403,+DDSFRM,0),U,11)=""
 K @DDSREFS
 Q

DDSZ1
DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;9:51 AM  25 Jan 1996
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN(DDSPG,DDSBK,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,DDSNDD,DDSPGRP,DDSSCR,DDSNAV,DDSORD,DDSRNAV) ;
 ;Input:
 ;  DDSREFS = Global ref
 ;Output:
 ;  DDSSCR
 ;  DDSNAV
 ;  DDSORD
 ;  DDSRNAV
 ;
 N Y
 S:$G(DDSTP)="" DDSTP="e"
 I DDSTP'="h",$G(DDSBO),$D(DDSORD(DDSBO))[0 D
 . S DDSORD(DDSBO)=DDSBK
 . S:$G(DDSREP)>1 $P(DDSORD(DDSBO),U,2)=$S($P(DDSREP,U,5)]"":$P($$GETFLD^DDSLIB($P(DDSREP,U,5),"","","","",DDSBK),","),1:"FIRST")
 ;
 S DDSF=0
 F  S DDSF=$O(^DIST(.404,DDSBK,40,DDSF)) Q:DDSF'=+DDSF  D FLD
 ;
KILL K DDSC1,DDSC2,DDSCAP,DDSCLN,DDSD1,DDSD2,DDSD3
 K DDSDDL0,DDSF,DDSFLD,DDSL0,DDSL01,DDSL2,DDSL4,DDSN
 Q
 ;
FLD ;Set up
 ;  @DDSREFS@(pg,bk,ddo,
 ;    "D")       = data $Y^data $X^data $L^field#
 ;                  ^xcap $Y^xcap $X^xcap colon^xcap req
 ;                  ^1 if computed field^1 if right justified
 ;    "COMPE")   = M code that sets X
 ;    "COMPE",1) = array sets DDSE(n)
 ;
 ;  @DDSREFS@("Ffile#",field#,"L",pg,bk,ddo)=""
 ;
 ;  DDSSCR(row)     = captions on that row
 ;  DDSSCR(row,col) = final columns underlined
 ;  DDSNAV(row,col) = ddo,bk for editable fields
 ;  DDSORD(bo,fo)   = ddo for editable fields
 ;
 ;Get field properties
 S:'$P(^DIST(.404,DDSBK,40,DDSF,0),U,3) $P(^(0),U,3)=3
 S DDSL0=$G(^DIST(.404,DDSBK,40,DDSF,0)),DDSL01=$G(^(.1)),DDSFLD=$S($P(DDSL0,U,3)=2:DDSF_","_DDSBK,1:+$G(^(1))),DDSL2=$G(^(2)),DDSL4=$G(^(4))
 K:$P(DDSL0,U,3)=3!'$P(DDSL0,U,3) DDSNDD
 S DDSDDL0=$G(^DD(DDP,DDSFLD,0)) Q:DDSL0?."^"!(DDSL2?."^")
 S DDSD1=$P($P(DDSL2,U),",")+DDSBY-1
 S DDSD2=$P($P(DDSL2,U),",",2)+DDSBX-1
 S DDSD3=$P(DDSL2,U,2)
 S DDSC1=$P($P(DDSL2,U,3),",")+DDSBY-1
 S DDSC2=$P($P(DDSL2,U,3),",",2)+DDSBX-1
 S DDSCAP=$TR($P(DDSL0,U,2)," ",$C(0))
 S DDSCLN=$S(DDSCAP="":"",$P(DDSL0,U,3)=1:"",$P(DDSL2,U,4):"",1:":")
 ;
 I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D
 . ;Set CAP xref for ^-jumping
 . I DDSTP="e","^2^3^"[(U_$P(DDSL0,U,3)_U)!'$P(DDSL0,U,3) D
 .. N C,I,L
 .. S I=0 F  S I=$O(DDSPGRP(I)) Q:'I  Q:U_DDSPGRP(I)_U[(U_DDSPG_U)
 .. Q:'I
 .. S C=$P(DDSL0,U,2)
 .. S:C?1"Select ".E C=$P(C,"Select ",2,999)
 .. S C=$E($TR(C,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),1,40)
 .. S L=$L(DDSREFS)+$L(C)+$L(DDSPGRP(I))+$L(DDSPG)+$L(DDSBK)+$L(DDSF)+30
 .. S:L>127 C=$E(C,1,$L(C)-(L-127))
 .. S:C]"" @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)=""
 . ;
 . ;Set DDSSCR
 . I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D
 .. N DDSI,DDSX
 .. S DDSX=DDSCAP_DDSCLN
 .. F DDSI=1:1:+DDSREP D
 ... S $E(DDSSCR(DDSC1+DDSI),DDSC2+1,DDSC2+$L(DDSX))=DDSX
 ... S:$P(DDSDDL0,U,2)["R"!+DDSL4 DDSSCR(DDSC1+DDSI,DDSC2+1)=DDSC2+$L(DDSCAP)
 ;
 ;Set "D", "L" nodes, DDSNAV, and DDSORD
 I DDSD1'<0,DDSD2'<0,DDSD3>0 D
 . S @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD
 . S @DDSREFS@("F"_$S(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)=""
 I DDSCAP="!M",DDSC1'<0,DDSC2'<0 S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,5,8)=DDSC1_U_DDSC2_U_DDSCLN_U_($P(DDSDDL0,U,2)["R"!+DDSL4)
 S:$P(DDSL4,U,3) $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1
 ;
 ;Computed fields
 I $P(DDSL0,U,3)=4 D  K DDSCOMP,DDSAR,DDSEXP,DDSFD Q
 . S DDSCOMP=$G(^DIST(.404,DDSBK,40,DDSF,30)) Q:DDSCOMP?."^"
 . D PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD)
 . Q:DDSEXP=""!$G(DIERR)
 . S @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP
 . F DDSAR=1:1:DDSAR D
 .. S:DDSAR(DDSAR)["*DDSREFC*" DDSAR(DDSAR)=$P(DDSAR(DDSAR),"*DDSREFC*")_$E(DDSREFS,1,$L(DDSREFS)-1)_",""COMPE"","_DDSBK_","_DDSF_","_DDSAR_$P(DDSAR(DDSAR),"*DDSREFC*",2,999)
 .. S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR)
 .. I $D(DDSAR(DDSAR))>9 N I F I=1:1 Q:$D(DDSAR(DDSAR,I))[0  D
 ... S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I)
 . S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1
 . I $G(DDSFD)]"" F DDSAR=1:1:$L(DDSFD,U) D
 .. N F S F=$P(DDSFD,U,DDSAR) Q:F=""
 .. S @DDSREFS@("COMP",$P(F,","),$P($P(F,",",2,99),";"),DDSPG,DDSBK,DDSF)=""
 ;
 Q:DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^")
 Q:$P(DDSDDL0,U,4)=" ; "  Q:DDSTP="h"  Q:DDSFLD=.001
 I '$P(DDSDDL0,U,2),DDSTP'="e" Q
 ;
 S DDSORD(DDSBO,+DDSL0)=DDSF
 S DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK
 S:$P(DDSDDL0,U,2) DDSMUL(DDSBK,DDSF)=""
 ;
 I $G(DDSREP)>1 D
 . N I
 . S DDSRNAV(DDSBO,DDSD1)=DDSBK
 . S DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF
 . S DDSRNAV(DDSBO,DDSD1-1,DDSD2)=DDSF_",-1"
 . S DDSRNAV(DDSBO,DDSD1+1,DDSD2)=DDSF_",+1"
 Q

DDSZ2
DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;11:01 AM  29 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN(SC,N,O,RNAV) ;
 ;Input:
 ;  DDSPG
 ;  DDSREFS
 ;
 D SCR(.SC),NAV(.N),ORD(.O)
 D:$D(RNAV) RNAV(.RNAV,.O)
 Q
 ;
SCR(SC) ;Move image from SC to global
 N C,P,R,S
 Q:'$D(SC)
 S R=0 F  S R=$O(SC(R)) Q:'R  D
 . F C=1:1 Q:$E(SC(R),C)'=" "
 . S @DDSREFS@("X",DDSPG,R-1,C-1)=$TR($E(SC(R),C,999),$C(0)," ")
 . I $D(SC(R))=11 D
 .. S S="",P=0
 .. F  S P=$O(SC(R,P)) Q:'P  S S=S_(P-C+1)_";"_(SC(R,P)-C+1)_";U"_U
 .. S:S?.E1"^" S=$E(S,1,$L(S)-1)
 .. S:S]"" @DDSREFS@("X",DDSPG,R-1,C-1,"A")=S
 Q
 ;
NAV(N) ;
 N B,D1,D2,F,LN
 S N(9999,1)="0,0"
 ;
 S D1="" F  S D1=$O(N(D1)) Q:D1=""  D
 . S D2="" F  S D2=$O(N(D1,D2)) Q:D2=""  D
 .. S F=$P(N(D1,D2),","),B=$P(N(D1,D2),",",2),LN=""
 .. D NAV1(.N,D1,D2,.LN)
 .. S @DDSREFS@(DDSPG,B,F,"N")=LN
 .. S:$D(DDSMUL(B,F)) $P(@DDSREFS@(DDSPG,B,F,"N"),U,11)=1
 Q
 ;
NAV1(N,D1,D2,LN) ;Setup "N" for navigation
 N E1,E2,I
 ;
 S E1=$S($O(N(D1),-1)]"":$O(N(D1),-1),1:$O(N(""),-1))
 S E2=D2
 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2)))
 I E1]"",E2]"" S $P(LN,U)=N(E1,E2)
 ;
 S E1=$S($O(N(D1))]"":$O(N(D1)),1:$O(N("")))
 S E2=D2
 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2)))
 I E1]"",E2]"" S $P(LN,U,2)=N(E1,E2)
 ;
 S E1=D1,E2=$O(N(D1,D2))
 I E2="" S E1=$S($O(N(E1))]"":$O(N(E1)),1:$O(N(""))),E2=$O(N(E1,""))
 I E1]"",E2]"" S $P(LN,U,3)=N(E1,E2)
 ;
 S E1=D1,E2=$S($O(N(E1,D2),-1)]"":$O(N(E1,D2),-1),1:"")
 I E2="" S E1=$S($O(N(E1),-1)]"":$O(N(E1),-1),1:$O(N(""),-1)),E2=$S($O(N(E1,""),-1)]"":$O(N(E1,""),-1),1:"")
 I E1]"",E2]"" S $P(LN,U,4)=N(E1,E2)
 ;
 F I=1:1:4 S:$P($P(LN,U,I),",",2)=B!'$P($P(LN,U,I),",",2) $P(LN,U,I)=+$P(LN,U,I)
 Q
 ;
ORD(O) ;Setup field order info
 N B,BO,BP,F,FO,FP
 S (BO,FO)="" F  S BO=$O(O(BO)) Q:BO=""  S FO=$O(O(BO,"")) Q:FO]""
 S:FO="" BO=$O(O(""))
 S B=+$G(O(+BO)),F=+$G(O(+BO,+FO))
 S @DDSREFS@(DDSPG,"FIRST")=F_","_B
 ;
 S (BP,FP)=0
 S BO="" F  S BO=$O(O(BO)) Q:BO=""  D
 . S B=+O(BO),F=0
 . S FO=$O(O(BO,"")) S:FO]"" F=O(BO,FO)
 . S $P(@DDSREFS@(DDSPG,B),U,9)=F
 . S:$P(O(BO),U,2)]"" $P(@DDSREFS@(DDSPG,B),U,10)=$S($P(O(BO),U,2)="FIRST":F,1:$P(O(BO),U,2))
 . S FO="" F  S FO=$O(O(BO,FO)) Q:FO=""  D
 .. S F=O(BO,FO)
 .. S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=F_$S(B'=BP:","_B,1:"")
 .. S FP=F,BP=B
 S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=0
 Q
 ;
RNAV(DDSRNAV,DDSO) ;Setup nav and fo info for rep blocks
 N DDSBO,DDSN,B,D1,D2,DN,F,F1,FO,LN,NX,RT
 S DDSBO="" F  S DDSBO=$O(DDSRNAV(DDSBO)) Q:DDSBO=""  D
 . ;N %X,%Y K DDSN S %X="DDSRNAV("_DDSBO_",",%Y="DDSN(" D %XY^%RCR
 . K DDSN M DDSN=DDSRNAV(DDSBO)
 . S D1="" F  S D1=$O(DDSN(D1)) Q:D1=""  D:$D(DDSN(D1))#2
 .. S B=DDSN(D1)
 .. S D2="" F  S D2=$O(DDSN(D1,D2)) Q:D2=""  D
 ... S F=$P(DDSN(D1,D2),","),LN=""
 ... D NAV1(.DDSN,D1,D2,.LN)
 ... S $P(@DDSREFS@(DDSPG,B,F,"N"),U,6,9)=LN
 . ;
 . S B=+$G(DDSO(+DDSBO)) Q:'B
 . S FO=$O(DDSO(DDSBO,"")) Q:FO=""
 . S (F,F1)=DDSO(DDSBO,FO)
 . F  S FO=$O(DDSO(DDSBO,FO)) Q:FO=""  D
 .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO)
 .. S F=DDSO(DDSBO,FO)
 . S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1"
 . ;
 . S DN=0
 . S F=0 F  S F=$O(@DDSREFS@(DDSPG,B,F)) Q:DN=2!(F="")  D
 .. S LN=$G(@DDSREFS@(DDSPG,B,F,"N")) Q:LN=""
 .. S RT=$P(LN,U,3),NX=$P(LN,U,5)
 .. S:RT[","!'RT DN=DN+1
 .. S:NX[","!'NX DN=DN+1
 . ;
 . S F=0 F  S F=$O(@DDSREFS@(DDSPG,B,F)) Q:F=""  D
 .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT
 .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX
 Q

DDSZ3
DDSZ3 ;SFISC/MKO-FORM COMPILER ;02:49 PM  30 Dec 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ASUB(DDSPG,DDSFRM) ;
 ;Set @DDSREFS@("ASUB",pg,bk,ddo)=subpage for parent field
 N MF,MB,MP
 S MF=$P(^DIST(.403,+DDSFRM,40,DDSPG,1),U,2) Q:MF=""
 S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",")
 ;
 S MF=$$GETFLD^DDSLIB(MF,MB,MP,DDSFRM)
 I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q
 S @DDSREFS@("ASUB",$P(MF,",",3),$P(MF,",",2),$P(MF,","))=DDSPG
 Q
 ;
PGRP(FRM,G) ;Find page groups
 ;In:  FRM = Form number
 ;Out: G   = Array of page groups
 ;
 N B,I,NP,P,PP,PG
 S G=0
 S P=0 F  S P=$O(^DIST(.403,FRM,40,P)) Q:'P  D
 . Q:'$D(^DIST(.403,FRM,40,P,0))  S NP=$P(^(0),U,4),PP=$P(^(0),U,5)
 . F PG="NP","PP" I @PG D
 .. S @PG=$O(^DIST(.403,FRM,40,"B",@PG,"")) Q:'@PG
 .. S:$D(^DIST(.403,FRM,40,@PG,0))[0 @PG=""
 . S:NP=P NP=0 S:PP=NP!(PP=P) PP=0
 . S I=0 F  S I=$O(G(I)) Q:'I  Q:U_G(I)_U[(U_P_U)
 . I 'I S G=G+1,G(G)=P_$S(NP:U_NP,1:"")_$S(PP:U_PP,1:"") Q
 . F PG="NP","PP" I @PG,U_G(I)_U'[(U_@PG_U) S G(I)=G(I)_U_@PG
 Q

DDU
DDU ;SFISC/DCM-DD UTILITES ;3/24/91  12:22 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DDU"","
 G OPT:$D(^DOPT("DDU",3)) S ^(0)="DATA DICTIONARY UTILITY OPTION^1.01" K ^("B")
 F X=1:1:3 S ^DOPT("DDU",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK
OPT ;
 S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
 ;
EN ;
 D @DI W !!
Q K %,DIC,DIK,DI,DA,I,J,X,Y Q
 ;
1 ;;LIST FILE ATTRIBUTES
 G ^DID
 ;
2 ;;MAP POINTER RELATIONS
 G ^DDMAP
 ;
3 ;;CHECK/FIX DD STRUCTURE
 G ^DDUCHK
 ;

DDUCHK
DDUCHK ;SFISC/RWF-CHECK DD ;8/12/94  9:01 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD
 ; DDUCRFI=referenced file, DDUCRFE=referenced field.
A W !!,"Check the Data Dictionary." S DDUC="" D DT^DICRW,L^DICRW1 G EXIT:X'>0 S DDUCFIS=+X-.000001,DDUCFIE=DIB(1)
 S DIR(0)="Y",DIR("A")="Remove erroneous nodes",DIR("B")="NO",DIR("?",1)="This routine will try to fix certain nodes that are erroneous and may set some nodes to a file referenced by the selected file."
 S DIR("?")="Say 'NO' here to leave the DD untouched.  It will only flag the ones it finds erroneous."
 D ^DIR G EXIT:$D(DIRUT) S DDUCFIX=+Y K DIR
ZIS S %ZIS="Q" D ^%ZIS G EXIT:POP
 I $D(IO("Q")) S ZTRTN="DQ^DDUCHK",ZTSAVE("DDUCFIX")="",ZTSAVE("DDUCFIS")="",ZTSAVE("DDUCFIE")="" D ^%ZTLOAD G EXIT
DQ U IO K DDUCSTK S DDUCSTK=0,DDUCFX=DDUCFIX
 F DDUCFILE=DDUCFIS:0:DDUCFIE S DDUCFILE=$O(^DIC(DDUCFILE)) Q:DDUCFILE'>0!(DDUCFILE>DDUCFIE)  D PAGE Q:$D(DIRUT)  W !!,"Checking file # ",DDUCFILE S (DDUCFI,DIFILE)=+DDUCFILE D DDAC,CHK
EXIT D ^%ZISC
 K DDUCFI,DDUCFIX,DDUCFILE,DDUCFIS,DDUCFIE,DDUCFE,DDUCX,DDUCX1,DDUCX2,DDUCX4,DDUCRFI
 K DDUCRFE,DDUCSTK,DDUCSTK,DDUCDNAM,DDUCNAME,DDUCXX,DDUCY,DDUCUP,DDUCXN
 K DDUCF,DDUCXREF,DDUCZ,DDUC5,DDUCYY,DDUCYY1,DDUCOK,DDUCYYX,DIB,DDUC,DDUCFX,DIAC,DIFILE
 Q
PAGE I $Y+3>IOSL S DIR(0)="E" D:IOST["C-" ^DIR W @IOF
 Q
 ;
DDAC I DUZ(0)'="@" S DIAC="DD" D ^DIAC S DDUCFIX=DDUCFX I 'DIAC,DDUCFX W !,"You don't have DD access to this file.  No fixing will be done on this file." S DDUCFIX=0 Q
 Q
CHK I $G(^DIC(DDUCFI,0))]"",'$P(^(0),U,2) S:DDUCFIX $P(^(0),U,2)=DDUCFI
 I $D(^DD(DDUCFI,0))[0 S DDUCRFI=DDUCFI D WFI W "is missing zero node of DD."
 I $D(^DD(DDUCFI,0,"ID")) W !?5,"Checking 'ID' nodes for 'Q'." D ID^DDUCHK1
 I $D(^DD(DDUCFI,0,"IX")) W !?5,"Checking 'IX' nodes." D IX^DDUCHK1
 I $D(^DD(DDUCFI,0,"PT")) W !?5,"Checking 'PT' nodes." D PT^DDUCHK1
 S DDUCNAME=$O(^DD(DDUCFI,0,"NM","")),DDUCDNAM=$O(^(DDUCNAME)),DDUCRFI=DDUCFI I DDUCDNAM]"" D WFI W "has duplicate 'NM' nodes." I DDUCFIX D NM^DDUCHK1
 I $D(^DD("ACOMP",DDUCFI)) D AC^DDUCHK1
 G ^DDUCHK2
WFI W !?8,"File: ",DDUCRFI," " Q
 ;
EN ;
 Q:'$D(DDUCFI)!'$D(DDUCFIX)  S U="^"
 I DDUCFI Q:'$D(^DIC(DDUCFI,0,"GL"))  G EN1
 Q:'$D(@(DDUCFI_"0)"))  S DDUCFI=+$P(^(0),U,2)
EN1 S DDUCFIS=+DDUCFI-.000001,DDUCFIE=+DDUCFI
 G ZIS

DDUCHK1
DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;8/28/94  06:48
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ID S DDUCRFE="" F DDUCZ=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"ID",DDUCRFE)) Q:DDUCRFE=""  S DDUCX=$S($D(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"") I DDUCX="Q" W !?5,"'ID' node for field ",DDUCRFE," = 'Q'" D:DDUCFIX ID1
 Q
ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2
 Q
IX S DDUCXREF="" F DDUCZ=0:0 S DDUCXREF=$O(^DD(DDUCFI,0,"IX",DDUCXREF)) Q:DDUCXREF=""  F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI)) Q:DDUCRFI'>0  D IX1
 Q
IX1 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0  D
 . I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI,WFE,WMS D:DDUCFIX IX2 Q
 . I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
 . S DDUCRFE1=0,DDUCRFEX="" F  S DDUCRFE1=$O(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1)) Q:DDUCRFE1'>0  S DDUCRFEX=$G(^(DDUCRFE1,0)) I $P(DDUCRFEX,U,2)=DDUCXREF K DDUCRFEX Q
 . I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q
 K DDUCRFE1 Q
IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2
 Q
PT F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"PT",DDUCRFI)) Q:DDUCRFI'>0  F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0  D PT1
 Q
PT1 I $D(^DD(DDUCRFI,0))[0 D WFI,WMS I DDUCFIX K ^DD(DDUCFI,0,"PT",DDUCRFI) D M1 W """PT"",",DDUCRFI D M2 Q
 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI,WFE,WMS D:DDUCFIX PTM Q
 I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q
 I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DDUCFI D WFI,WFE W "is not a pointer to file ",DDUCFI D:DDUCFIX PTM
 Q
PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
 D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2
 Q
AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0  D AC1
 Q
AC1 F DDUCRFI=0:0 S DDUCRFI=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI)) Q:DDUCRFI'>0  F DDUCRFE=0:0 S DDUCRFE=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0  D AC2
 Q
AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q
 S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q
 I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3
 Q
AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2=""  I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q
 I 'DDUCF D:DDUCFIX ACM
 Q
ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
 Q
NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD"))
 Q:DDUCRFI(1)']""  K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted."
 Q
WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q
WFI W !?5,"File: ",DDUCRFI," " Q
WFE W ?5,"Field: ",DDUCRFE," " Q
WMS W "is missing." Q
M1 W !?10,"^DD(",DDUCFI,",0," Q
M2 W ") was killed." Q

DDUCHK2
DDUCHK2 ;SFISC/RWF-CHECK DD (FIELDS) ;5/28/91  2:35 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CHK6 W !?5,"Checking FIELDs"
 F DDUCFE=0:0 S DDUCFE=+$O(^DD(DDUCFI,DDUCFE)) Q:DDUCFE'>0  D FIELD Q:$D(DIRUT)  D FIVE,XREF^DDUCHK3,COMP^DDUCHK3
 Q
FIELD W "."
 I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?8,"Field: ",DDUCFE," is missing its zero node.  Nothing done."
 S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U)
 ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set."
 D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q
 Q
FIVE K DDUCXX F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,5,DDUCY)) Q:DDUCY'>0  S DDUCX=^(DDUCY,0) I $D(^DD(+DDUCX,+$P(DDUCX,U,2),1,+$P(DDUCX,U,3),0))#2 S DDUCXX(DDUCX)=""
 Q:'DDUCFIX
 K ^DD(DDUCFI,DDUCFE,5)
 S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX=""  S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
 Q
VP F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,"V",DDUCY)) Q:DDUCY'>0  S DDUCRFI=$S($D(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"") I DDUCRFI D PT1
 Q
PT S DDUCRFI=+$P(DDUCX2,"P",2) I $D(^DD(DDUCRFI,0))[0 D WHO W "points to missing file: ",DDUCRFI Q
PT1 I $D(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0 D WHO W "is missing its 'PT' node in the pointed-to-file." I DDUCFIX S ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)="" W !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set."
Q Q  ;QUIT TAG
MULT ;Work subfile
 D PAGE^DDUCHK Q:$D(DIRUT)
 I $D(^DD(+DDUCX2,0))[0 D WHO W "missing subfile: ",+DDUCX2 Q
 S DDUCUP=$S($D(^DD(+DDUCX2,0,"UP")):^("UP"),1:"") I DDUCUP'=DDUCFI D WHO W "Bad 'UP' pointer in subfile #",+DDUCX2 I DDUCFIX S ^DD(+DDUCX2,0,"UP")=DDUCFI W !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set."
 D PUSH S DDUCFI=+DDUCX2 W !?3,"Checking subfile # ",DDUCFI D CHK^DDUCHK,POP W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:".",1:" "_DDUCFI)
 Q
PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q
POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q
WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q

DDUCHK3
DDUCHK3 ;SFISC/RWF-CHECK DD (XREF,COMPUTED) ;2/1/91  3:39 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
XREF F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,1,DDUCY)) Q:DDUCY'>0  S DDUCX=^(DDUCY,0),DDUCRFI=+DDUCX,DDUCX1=$P(DDUCX,U,2) D XREF1
 Q
XREF1 I DDUCRFI,$D(^DD(DDUCRFI,0)),$D(^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE))[0 D WHO,WFI W "missing 'IX' node." D:DDUCFIX XREFM Q
 I DDUCX["TRIGGER" S DDUCRFI=+$P(DDUCX,U,4),DDUCRFE=+$P(DDUCX,U,5),DDUC5=DDUCFI_U_DDUCFE_U_DDUCY D TRIG
 Q
XREFM S ^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE)="" W !?10,"^DD(",DDUCRFI,",0,""IX"",""",DDUCX1,""",",DDUCFI,",",DDUCFE,") = """" was set."
 Q
TRIG I $D(^DD(DDUCRFI,0))[0 D WHO W "triggers missing file ",DDUCRFI Q
 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WHO W "triggers missing field ",DDUCRFE," in file ",DDUCRFI Q
 I '$D(^DD(DDUCRFI,DDUCRFE,5)) D WHO,WFI,WFE W " 5 node is missing." I DDUCFIX S ^DD(DDUCRFI,DDUCRFE,5,1,0)=DDUC5 W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,1,0) = ",DDUC5," was set." Q
 Q:'DDUCFIX  S (DDUCYY1,DDUCOK)=0
 F DDUCYY=0:0 S DDUCYY=$O(^DD(DDUCRFI,DDUCRFE,5,DDUCYY)) Q:DDUCYY'>0  S DDUCYY1=DDUCYY,DDUCYYX=^(DDUCYY,0) I DDUCYYX=DDUC5 S DDUCOK=1 Q
 I 'DDUCOK D WHO,WFI,WFE W " 5 node is missing." D:DDUCFIX TRIGM Q
 Q
TRIGM S ^DD(DDUCRFI,DDUCRFE,5,(DDUCYY1+1),0)=DDUC5
 I DDUCRFI'=DDUCFE W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,",DDUCYY1+1,",0) = ",DDUC5," was set."
 Q
COMP Q:DDUCX2'["C"  S DDUCX=$S($D(^DD(DDUCFI,DDUCFE,9.01)):^(9.01),1:"")
 F DDUCX1=1:1 Q:$P(DDUCX,";",DDUCX1)=""  S DDUCRFI=+$P(DDUCX,";",DDUCX1),DDUCRFE=+$P($P(DDUCX,";",DDUCX1),U,2) I $D(^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE))[0 S:DDUCFIX ^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE)=""
 Q
WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q
WFI W !?8,"File: ",DDUCRFI," " Q
WFE W ?8,"Field: ",DDUCRFE," " Q

DDW
DDW ;SFISC/PD KELTZ-SCREEN EDITOR MAIN ROUTINE ;08:33 AM  28 Mar 1995
 ;;21.0;VA FileMan;**4**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
MAIN N DX,DY,IOTM,IOBM
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 ;
 D INIT I $G(DDWERR) K DDWERR Q
 D ^DDWT1,END
 Q
 ;
EDIT(DIC,DDWFLG,DIWETXT,DIWESUB,DDWRW,DDWC,DDWTM,DDWBM,DDWLMAR,DDWRMAR) ;
 N DWHD,DWLC
 G MAIN
 ;
MSG(DDWX) ;Write message
 S DY=$G(DDWBM,IOSL)-1,DX=0 X IOXY
 W $P(DDGLCLR,DDGLDEL)_$G(DDWX)
 I $G(DDWX)="",$D(DDWMARK) D IND^DDW7(1)
 Q
 ;
INIT ;Setup, initialize variables
 N X,DDWI
 D INIT^DDGLIB0() G:$G(DIERR) ERR
 I $P(DDGLED,DDGLDEL,2)_$P(DDGLED,DDGLDEL,3)_$P(DDGLED,DDGLDEL,4)="" D TRMERR^DDGLIB0("Set Top and Bottom Margins, Delete Line, and Insert Line") G ERR
 ;
 G:'$D(DIC) FERR
 S DDWDIC=$$CREF^DILF(DIC) G:'$D(@DDWDIC) FERR
 S X="S X="_DDWDIC D ^DIM G:'$D(X) FERR
 S DIC=$$OREF^DILF(DDWDIC)
 ;
 I IOSL>100 S DDWIOSL=IOSL,IOSL=24
 S IOTM=$G(DDWTM,1)+2,IOBM=$G(DDWBM,IOSL)-3
 I IOBM-IOTM<3 D BLD^DIALOG(202,"Top and/or Bottom Margin") G ERR
 ;
 S:'$G(DDWLMAR) DDWLMAR=1 S:'$G(DDWRMAR) DDWRMAR=74
 I DDWRMAR'>DDWLMAR!(DDWLMAR>231)!(DDWRMAR>245) D BLD^DIALOG(202,"Left and/or Right Margin") G ERR
 ;
 D:$D(DDW("IN"))[0 GETKEY^DDWK
 ;
 D CLR
 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2)
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 ;
 K DDWL,^TMP("DDW",$J),^TMP("DDW1",$J)
 S (DDWA,DDWSTB,DDWSTAT,DDWREP)=0,DDWBF="0010"
 ;
 S DDWRAP=$G(DDWFLG)'["M"
 I 'DDWRAP D
 . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1
 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245
 ;
 I '$G(DDWRW),$G(DDWRW)'="B" S DDWRW=1
 I '$G(DDWC),$G(DDWC)'="E" S DDWC=1
 ;
 S DDWTO=DTIME
 S DDWOFS="0^20^^1",$P(DDWOFS,U,3)=IOM-$P(DDWOFS,U,2)
 S DDWMR=IOBM-IOTM+1
 ;
 S DDWRUL=$TR($J("",255)," ","=")
 F DDWI=1:1:31 S $E(DDWRUL,DDWI*8)="T"
 Q
 ;
RESET ;Reset terminal and cleanup
 D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW")
 W $P($G(DDGLVID),DDGLDEL,10)
 ;
END ;Cleanup
 S:$D(DDWIOSL)#2 IOSL=DDWIOSL
 I $P(DDGLED,DDGLDEL,2)]"" D
 . S IOTM=1,IOBM=$S($D(IOSL)#2:IOSL,1:24) W @$P(DDGLED,DDGLDEL,2)
 D CLR
 ;
 K DDW,DDWA,DDWBF,DDWC,DDWCHG,DDWCNT,DDWDIC,DDWFIN,DDWFIND,DDWHLOG
 K DDWIOSL,DDWL,DDWMARK,DDWMR,DDWN,DDWOFS,DDWQ,DDWRAP,DDWREP
 K DDWRUL,DDWRW,DDWSTAT,DDWSTB,DDWTC,DDWTO
 K ^TMP("DDW",$J),^TMP("DDW1",$J),^TMP("DDWH",$J)
 I $$ROUEXIST^DILIBF("XPDUTL"),$$VERSION^XPDUTL("XU")>7.1
 E  K ^TMP("DDWB",$J)
 ;
 ;D:'$D(DIWE) X^DIWE
 D:$D(DDS)[0 KILL^DDGLIB0($G(DDWFLG))
 Q
 ;
CLR ;Clear screen
 I $G(DDWTM,1)=1,$G(DDWBM,IOSL)=IOSL W $P(DDGLCLR,DDGLDEL,2)
 E  D
 . S DX=0
 . F DY=$G(DDWTM,1)-1:1:$G(DDWBM,IOSL)-1 X IOXY W $P(DDGLCLR,DDGLDEL)
 Q
 ;
FERR ;File input parameter error
 D BLD^DIALOG(202,"File")
 D ERR
 Q
 ;
ERR ;Error during setup
 W $C(7),! D MSG^DIALOG("BW") W !
 D KILL^DDGLIB0()
 S DDWERR=1
 Q

DDW1
DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;1:03 PM  22 Sep 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
LOAD ;Put up "box" and load document
 N DDWI,DDWX
 D BOX
 ;
 I $D(DWLC)[0 D
 . S DWLC=$S($D(@DDWDIC@(0))#2:+$P(@DDWDIC@(0),U,4),1:$O(@DDWDIC@(""),-1))
 . S:$D(@DDWDIC@(1))#2 $E(DDWBF,4)=1
 S DDWCNT=$S(DWLC:DWLC,1:1)
 ;
 D:DDWCNT>1 MSG^DDW("Loading text ...")
 F DDWI=DDWCNT:-1:DDWMR+1 D
 . S DDWSTB=DDWSTB+1
 . S ^TMP("DDW1",$J,DDWSTB)=$S('$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI)))
 ;
 F DDWI=1:1:DDWMR D
 . S DDWX=$S(DDWI>DDWCNT:"",'$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI)))
 . S DDWL(DDWI)=DDWX
 . I DDWC'>IOM,DDWRW'>DDWMR,DDWI'>DDWCNT,DDWX'?." " D
 .. D CUP(DDWI,1) W $E(DDWX,1,IOM)
 ;
 I DDWCNT=1,DDWL(1)?1." " S DDWL(1)=""
 D:DDWCNT>1 MSG^DDW()
 I DDWRW="B" D
 . D BOT^DDW3
 E  D LINE^DDWG(DDWRW,DDWC)
 Q
 ;
BOX ;Draw box
 N DDWX
 ;
 I $D(DIWETXT) D
 . D CUP(-1,1)
 . W $P(DDGLVID,DDGLDEL)_$E(DIWETXT,1,IOM)_$P(DDGLVID,DDGLDEL,10)
 ;
 I $D(DIWESUB) S DDWX=DIWESUB
 E  I $D(XMSUB),DIC["^XMB" D
 . S DDWX=XMSUB
 . F  Q:DDWX'["~U~"  S DDWX=$P(DDWX,"~U~")_U_$P(DDWX,"~U~",2,999)
 E  I $D(DH)#2,$D(DIE) S DDWX=DH
 S DDWX=$E($G(DDWX),1,30)
 ;
 D CUP(0,1) W $TR($J("",IOM)," ","=")
 I DDWRAP S DX=2 X IOXY W "[ WRAP ]"
 S DX=12 X IOXY W $S(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")
 S DX=40-($L(DDWX)\2) X IOXY W "< "_$E(DDWX,1,30)_" >"
 S DX=61 X IOXY W "[ <PF1>H=Help ]"
 ;
 D CUP(DDWMR+1,1) W $E(DDWRUL,1,IOM)
 I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D
 . S DX=DDWLMAR-DDWOFS-1 X IOXY W "<"
 I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D
 . S DX=DDWRMAR-DDWOFS-1 X IOXY W ">"
 Q
 ;
SV ;Called from DDWT1
 D SAVE
 S:DDWCNT<1 DDWCNT=1
 I DDWRW+DDWA>DDWCNT D
 . D POS(DDWCNT-DDWA,"E","RN")
 E  D POS(DDWRW,DDWC)
 Q
 ;
SAVE ;Save document
 N DDWI,DDWLMEM,DDWLSTB,DDWX
 D MSG^DDW("Saving text ...") H .5
 S DDWCNT=0
 K @DDWDIC
 ;
 F DDWI=1:1:DDWA D
 . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW",$J,DDWI))
 . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
 . E  S @DDWDIC@(DDWCNT)=DDWX
 ;
 S DDWLMEM=999
 F DDWI=1:1:DDWSTB+1 Q:DDWI>DDWSTB  Q:^TMP("DDW1",$J,DDWI)'?." "
 I DDWI'>DDWSTB S DDWLSTB=DDWI
 E  D
 . F DDWI=DDWMR:-1:0 Q:'DDWI  Q:DDWL(DDWI)'?." "
 . S DDWLMEM=DDWI
 ;
 F DDWI=1:1:$$MIN(DDWLMEM,DDWMR) D
 . S DDWCNT=DDWCNT+1,DDWX=$$NTS(DDWL(DDWI))
 . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
 . E  S @DDWDIC@(DDWCNT)=DDWX
 ;
 I $D(DDWLSTB) F DDWI=DDWSTB:-1:DDWLSTB D
 . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW1",$J,DDWI))
 . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
 . E  S @DDWDIC@(DDWCNT)=DDWX
 ;
 S DWLC=DDWCNT,DWHD=U
 I DDWCNT,'$E(DDWBF,4) S @DDWDIC@(0)=U_U_DWLC_U_DWLC_U_DT_U
 D MSG^DDW()
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
CUP(Y,X) ;Cursor positioning
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
MIN(X,Y) ;Return the minimum of X and Y
 Q $S(X<Y:X,1:Y)
 ;
NTS(X) ;Change "" to " "
 Q $S(X="":" ",1:X)
 ;
TR(X,F) ;Strip trailing blanks
 ;If F["B" return " " if X=""
 I $G(X)]"" D
 . N I
 . F I=$L(X):-1:0 Q:$E(X,I)'=" "
 . S X=$E(X,1,I)
 I X="",$G(F)["B" S X=" "
 Q X

DDW2
DDW2 ;SFISC/MKO-SETTINGS, MODES ;7:15 AM  6 Sep 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
TSET N DDWX
 S DDWX=$E(DDWRUL,DDWC)
 S DDWX=$S(DDWX="T":"=",DDWX="=":"T",1:DDWX)
 S $E(DDWRUL,DDWC)=DDWX
 I DDWC'=DDWLMAR,DDWC'=DDWRMAR D
 . D CUP(DDWMR+1,DDWC-DDWOFS) W DDWX
 . D POS(DDWRW,DDWC)
 Q
 ;
LSET I 'DDWRAP D ERR("Margins cannot be set when wrap is off") Q
 I DDWC>231 D ERR("Left margin cannot be set beyond column 231") Q
 I DDWC'<DDWRMAR D ERR("Left margin must be left of right margin") Q
 I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D
 . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W $E(DDWRUL,DDWLMAR)
 D CUP(DDWMR+1,DDWC-DDWOFS) W "<" D POS(DDWRW,DDWC)
 S DDWLMAR=DDWC
 Q
 ;
RSET I 'DDWRAP D ERR("Margins cannot be set when wrap is off") Q
 I DDWC>245 D ERR("Right margin cannot be set beyond column 245") Q
 I DDWC'>DDWLMAR D ERR("Right margin must be right of left margin") Q
 I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D
 . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W $E(DDWRUL,DDWRMAR)
 D CUP(DDWMR+1,DDWC-DDWOFS) W ">" D POS(DDWRW,DDWC)
 S DDWRMAR=DDWC
 Q
 ;
WRAPM S DDWRAP=DDWRAP+1#2
 D CUP(0,3) W $S(DDWRAP:"[ WRAP ]",1:"========")
 I 'DDWRAP D
 . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1
 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245
 E  D
 . S DDWLMAR=DDWLMAR(1) K DDWLMAR(1)
 . S DDWRMAR=DDWRMAR(1) K DDWRMAR(1)
 D RULER^DDW3,POS(DDWRW,DDWC)
 Q
 ;
REPLM S DDWREP=DDWREP+1#2
 D CUP(0,13) W $S(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")
 D POS(DDWRW,DDWC)
 Q
 ;
STAT S DDWSTAT=DDWSTAT+1#2
 I DDWSTAT D
 . S DDWTO=1,DDWTC=1
 E  D
 . D CUP(DDWMR+2,1)
 . W $P(DDGLCLR,DDGLDEL) D POS(DDWRW,DDWC)
 . S DDWTO=DTIME
 Q
 ;
CUP(Y,X) ;Cursor positioning
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
SCR(C) ;Return screen number
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
ERR(DDWX) ;Error
 W $C(7)
 D MSG^DDW(DDWX) H 2 D MSG^DDW()
 F  R *DDWX:0 E  Q
 D POS(DDWRW,DDWC)
 Q

DDW3
DDW3 ;SFISC/MKO-TOP, BOTTOM, SCROLL ;9:08 AM  13 Feb 1996
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
TOP N DDWI
 I DDWA=0 D POS(1,1,"RN") Q
 D SHFTUP(1),POS(1,1,"RN")
 Q
 ;
SHFTUP(DDWFL) ;
 N DDWSH,DDWI
 S DDWSH=DDWA+1-DDWFL
 D:DDWSH>DDWMR MSG^DDW("Repositioning ...")
 ;
 F DDWI=DDWMR:-1:$$MAX(1,DDWMR-DDWSH+1) D:DDWI+DDWA'>DDWCNT
 . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI)
 . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI)
 ;
 I $E(DDWBF,2) F DDWI=DDWA:-1:DDWFL+DDWMR D
 . S DDWSTB=DDWSTB+1
 . S ^TMP("DDW1",$J,DDWSTB)=^TMP("DDW",$J,DDWI)
 E  S DDWSTB=$$MAX(DDWCNT-DDWFL+1-DDWMR,0)
 ;
 S DDWA=DDWFL-1
 I DDWSH>DDWMR D
 . F DDWI=1:1:DDWMR S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1)
 . I $P(DDWOFS,U,4)=1 D
 .. D CUP(1,1)
 .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI<DDWMR:$C(13,10),1:"")
 . D MSG^DDW()
 E  D
 . F DDWI=DDWMR:-1:DDWSH+1 S DDWL(DDWI)=DDWL(DDWI-DDWSH)
 . F DDWI=DDWSH:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1)
 . D:$P(DDWOFS,U,4)=1 SCRDN(DDWSH)
 ;
 S:'DDWA $E(DDWBF,2)=0
 Q
 ;
BOT N DDWI
 I DDWSTB=0 D POS($$MIN(DDWMR,DDWCNT-DDWA),"E","RN") Q
 D SHFTDN($$MAX(1,DDWCNT-DDWMR+1))
 D POS(DDWMR,"E","RN")
 Q
 ;
SHFTDN(DDWFL,DDWCOL) ;
 N DDWNSTB,DDWSH,DDWI
 S DDWSH=DDWFL-DDWA-1,DDWNSTB=DDWCNT-DDWFL+1
 D:DDWSH>DDWMR MSG^DDW("Repositioning ...")
 ;
 F DDWI=1:1:$$MIN(DDWSH,DDWMR) D
 . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI)
 . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
 .
 ;
 I $E(DDWBF,3) F DDWI=DDWSTB:-1:DDWNSTB+1 D
 . S DDWA=DDWA+1
 . S ^TMP("DDW",$J,DDWA)=^TMP("DDW1",$J,DDWI)
 E  S DDWA=DDWFL-1
 ;
 I DDWSH>DDWMR D
 . F DDWI=1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"")
 . I $P(DDWOFS,U,4)=$$SCR($S($D(DDWCOL):DDWCOL,1:$L(DDWL(DDWMR))+1)) D
 .. D CUP(1,1)
 .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI<DDWMR:$C(13,10),1:"")
 . D MSG^DDW()
 E  D
 . F DDWI=1:1:DDWMR-DDWSH S DDWL(DDWI)=DDWL(DDWI+DDWSH)
 . F DDWI=DDWMR-DDWSH+1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"")
 . D:$P(DDWOFS,U,4)=$$SCR($L(DDWL(DDWMR))+1) SCRUP(DDWSH)
 ;
 S DDWSTB=$$MAX(0,DDWNSTB-DDWMR)
 S:'DDWSTB $E(DDWBF,3)=0
 Q
 ;
MVFWD(DDWNUM) ;
 N DDWI
 F DDWI=1:1:DDWNUM D
 . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI)
 . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI)
 F DDWI=1:1:DDWMR-DDWNUM S DDWL(DDWI)=DDWL(DDWI+DDWNUM)
 F DDWI=DDWMR-DDWNUM+1:1:DDWMR D
 . S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1
 D SCRUP(DDWNUM)
 Q
 ;
SCRUP(DDWNUM) ;
 N DDWI
 D CUP(DDWMR,1)
 F DDWI=DDWMR-DDWNUM+1:1:DDWMR D
 . I $P(DDGLED,DDGLDEL,2)]"" W $C(10)
 . E  D
 .. D CUP(1,1) W $P(DDGLED,DDGLDEL,4)
 .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3)
 . I DDWL(DDWI)'?." " D
 .. D CUP(DDWMR,1)
 .. W $$LINE(DDWI,$G(DDWMARK))
 D POS(DDWMR,DDWC,"RN")
 Q
 ;
MVBCK(DDWNUM) ;
 N DDWI
 F DDWI=DDWMR:-1:DDWMR-DDWNUM+1 D:DDWI+DDWA'>DDWCNT
 . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI)
 . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI)
 F DDWI=DDWMR:-1:DDWNUM+1 S DDWL(DDWI)=DDWL(DDWI-DDWNUM)
 F DDWI=DDWNUM:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWA),DDWA=DDWA-1
 D SCRDN(DDWNUM)
 Q
 ;
SCRDN(DDWNUM) ;
 N DDWI
 D CUP(1,1)
 F DDWI=DDWNUM:-1:1 D
 . I $P(DDGLED,DDGLDEL,2)]"" W $P(DDGLED,DDGLDEL)
 . E  D
 .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4)
 .. D CUP(1,1) W $P(DDGLED,DDGLDEL,3)
 . I DDWL(DDWI)'?." " D
 .. D CUP(1,1)
 .. W $$LINE(DDWI,$G(DDWMARK))
 D POS(1,DDWC,"RN")
 Q
 ;
ERR ;
 W $C(7)
 Q
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
SHIFT(C,DDWOFS) ;
 N DDWI,N,M,S
 S N=$P(DDWOFS,U,2),M=$P(DDWOFS,U,3)
 S S=$$SCR(C)
 S DDWOFS=S-1*M_U_N_U_M_U_S
 D RULER
 F DDWI=1:1:$$MIN(DDWMR,DDWCNT) D
 . S DY=IOTM+DDWI-2,DX=0 X IOXY
 . W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))
 Q
 ;
RULER ;Write ruler
 D CUP(DDWMR+1,1)
 W $P(DDGLCLR,DDGLDEL)_$E(DDWRUL,1+DDWOFS,IOM+DDWOFS)
 I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D
 . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W "<"
 I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D
 . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W ">"
 Q
 ;
LINE(DDWI,DDWMARK) ;
 N DDWX
 S DDWX=$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 Q:$G(DDWMARK)="" DDWX
 ;
 N DDWR1,DDWC1,DDWR2,DDWC2
 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2)
 S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4)
 ;
 I DDWI'<(DDWR1-DDWA),DDWI'>(DDWR2-DDWA) D
 . N DDWX1,DDWX2
 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1)
 . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999)
 . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS)
 Q DDWX
 ;
SCR(C) ;
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDW4
DDW4 ;SFISC/PD KELTZ-OTHER NAVIGATION, DEL ;09:00 AM  23 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
TAB N DDWX
 S DDWX=$F(DDWRUL,"T",DDWC+1) G:'DDWX ERR
 D POS(DDWRW,DDWX-1,"R")
 Q
 ;
DEOL S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
 W $P(DDGLCLR,DDGLDEL)
 Q
 ;
DELW N DDWI,DDWW
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 I DDWC>$L(DDWN) D  Q
 . I DDWN?." " D
 .. D XLINE^DDW5()
 . E  D
 .. N DDWY,DDWX
 .. S DDWY=DDWRW+DDWA,DDWX=DDWC
 .. D JOIN^DDW6
 .. D POS(DDWY-DDWA,DDWX,"RN")
 ;
 S DDWI=$$WRPOS(DDWN)
 S DDWW=$E(DDWN,DDWC,DDWI-1)
 S $E(DDWN,DDWC,DDWI-1)="",DDWL(DDWRW)=DDWN
 I $P(DDGLED,DDGLDEL,6)]"" D
 . F DDWI=1:1:$L(DDWW) W $P(DDGLED,DDGLDEL,6)
 . S DDWI=$E(DDWN,IOM-$L(DDWW)+1+DDWOFS,IOM+DDWOFS)
 . I DDWI]"" D CUP(DDWRW,IOM-$L(DDWW)+1) W DDWI D CUP(DDWRW,DDWC-DDWOFS)
 E  D
 . W $E(DDWN_$J("",$L(DDWW)),DDWC,IOM+DDWOFS)
 . D CUP(DDWRW,DDWC-DDWOFS)
 Q
 ;
WORDR N DDWI
 S DDWI=$$WRPOS(DDWN)
 D POS(DDWRW,DDWI,"R")
 Q
 ;
WRPOS(DDWT) ;
 N DDWP,DDWS
 S DDWT=$$PUNC(DDWT)
 S DDWS=$F(DDWT," ",DDWC+1),DDWP=$F(DDWT,"!",DDWC+1)
 S:'DDWS DDWS=999 S:'DDWP DDWP=999
 ;
 I DDWC>$L(DDWT) D
 . I DDWRW+DDWA'<DDWCNT S DDWI=$L(DDWT)+1
 . E  D DN^DDWT1 S DDWI=1
 E  I DDWS=999,DDWP=999 D
 . S DDWI=$L(DDWT)+1
 E  I $E(DDWT,DDWC)="!" D
 . F DDWI=DDWC+1:1 Q:$E(DDWT,DDWI)'="!"
 . F DDWI=DDWI:1 Q:$E(DDWT,DDWI)'=" "
 E  I DDWS<DDWP D
 . F DDWI=DDWS:1 Q:$E(DDWT,DDWI)'=" "
 E  S DDWI=DDWP-1
 Q DDWI
 ;
WORDL N DDWD,DDWI,DDWT
 S DDWT=$$PUNC(DDWN)
 ;
 I DDWC=1 D
 . I DDWRW=1,'DDWA S DDWI=1
 . E  D UP^DDWT1 S DDWI=$L(DDWN)+1
 E  D
 . S DDWI=DDWC-1
 . S:$E(DDWT,DDWI)="" DDWI=$L(DDWT)
 . I $E(DDWT,DDWI)=" " F DDWI=DDWI-1:-1:0 Q:$E(DDWT,DDWI)'=" "
 . I $E(DDWT,DDWI)="!" D
 .. F DDWI=DDWI-1:-1:0 Q:$E(DDWT,DDWI)'="!"
 . E  I DDWI D
 .. F DDWI=DDWI-1:-1:0 Q:" !"[$E(DDWT,DDWI)
 . S DDWI=DDWI+1
 D POS(DDWRW,DDWI,"R")
 Q
 ;
PGDN N DDWX
 I DDWRW<DDWMR D
 . D POS($$MIN(DDWCNT-DDWA,DDWMR),DDWC,"RN")
 E  D
 . S DDWX=$$MIN(DDWSTB,DDWMR)
 . D:DDWX MVFWD^DDW3(DDWX)
 Q
 ;
PGUP N DDWX
 I DDWRW>1 D
 . D POS(1,DDWC,"RN")
 E  D
 . S DDWX=$$MIN(DDWA,DDWMR)
 . D:DDWX MVBCK^DDW3(DDWX)
 Q
 ;
JLEFT N DDWX
 I DDWN?." " S DDWX=1
 E  F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" "
 I DDWC-DDWOFS=1,DDWC>1 D POS(DDWRW,DDWC-1,"R") Q:DDWC=DDWX
 S DDWC=$$MAX($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:0),1+DDWOFS)
 D POS(DDWRW,DDWC,"R")
 Q
JRIGHT N DDWX
 S DDWX=$L(DDWN)+1
 I DDWC-DDWOFS=IOM,DDWC<246 D POS(DDWRW,DDWC+1,"R") Q:DDWC=DDWX
 S DDWC=$$MIN($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:999),$$MIN(IOM+DDWOFS,246))
 D POS(DDWRW,DDWC,"R")
 Q
 ;
LBEG N DDWX
 F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" "
 D POS(DDWRW,DDWX,"R")
 Q
LEND D POS(DDWRW,"E","R")
 Q
 ;
ERR ;Beep
 W $C(7)
 Q
 ;
CUP(Y,X) ;Cursor positioning
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
SCR(C) ;Screen #
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)
PUNC(X) ;
 Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!"))

DDW5
DDW5 ;SFISC/PD KELTZ-WRAP, BREAK, ILINE, XLINE ;01:23 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
WRAP ;Wrap at word boundary
 S:$E(DDWN,DDWC,999)?1." " (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
 I DDWC'>$L(DDWN) D WRAPI Q
 I 'DDWRAP D POS(DDWRW,DDWRMAR+1,"R"),BREAK(1) Q
 D WRAPW
 Q
 ;
WRAPI ;Cursor in middle
 I $E(DDWN,DDWLMAR,999)'[" "!'DDWRAP D BREAK(-1),POS(DDWRW-1,"E","RN") Q
 N DDWCSV,DDWI,DDWLST,DDWRMSV
 S DDWI=$F(DDWN," ",DDWC)
 I DDWI,DDWI-2'>DDWRMAR D
 . S DDWCSV=DDWC
 . S (DDWN,DDWL(DDWRW))=$$TR(DDWN)
 . D POS(DDWRW,DDWI,"R"),BREAK(-1),POS(DDWRW-1,DDWCSV,"RN")
 . S (DDWN,DDWL(DDWRW))=$$TR(DDWN)
 E  I DDWC=2 D
 . D POS(DDWRW,DDWRMAR+1,"R"),BREAK(-1),POS(DDWRW-1,2,"RN")
 E  D
 . S DDWLST=$$TR($E(DDWN,DDWC,999))
 . S (DDWL(DDWRW),DDWN)=$E(DDWN,1,DDWC-1)
 . S DDWRMSV=DDWRMAR,DDWRMAR=$$MIN(DDWRMAR,DDWC-2)
 . D WRAPW
 . W $E(DDWLST,1,IOM+DDWOFS-DDWC)
 . S DDWL(DDWRW)=DDWN_DDWLST,DDWRMAR=DDWRMSV
 . D POS(DDWRW,DDWC,"RN")
 Q
 ;
WRAPW ;Cursor at end
 N DDWI,DDWS1,DDWS2,DDWTXT
 S DDWTXT(1)=DDWN
 D ADJMAR^DDW6(.DDWTXT,"","I")
 ;
 S DDWS1=$$SCR($L(DDWTXT(1))+1),DDWS2=$$SCR($L(DDWTXT(DDWTXT))+1)
 I DDWS1=$P(DDWOFS,U,4),DDWS2=$P(DDWOFS,U,4),DDWTXT=2 D
 . S (DDWN,DDWL(DDWRW))=DDWTXT(1)_DDWTXT(2)
 . S DDWC=$L(DDWTXT(1))+1
 . D POS(DDWRW,DDWC),BREAK(1)
 ;
 E  D
 . F DDWI=1:1:DDWTXT-1 D
 .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
 .. D ILINE
 .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI+1)
 .. I DDWS2=$P(DDWOFS,U,4) D
 ... D CUP(DDWRW-1,1)
 ... W $P(DDGLCLR,DDGLDEL)_$E(DDWTXT(DDWI),1+DDWOFS,IOM+DDWOFS)
 ... D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 . D POS(DDWRW,"E","R")
 Q
 ;
BREAK(DDWFLAG) ;Break line, make new line current
 ;Final cursor position:
 ; 0:lmar of new line (used by <RET>)
 ; 1:end of new line (used by Wrap)
 ;-1:doesn't matter (used by Wrap)
 N DDWRST
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 S DDWRST=$E(DDWN,DDWC,999)
 I DDWLMAR>1,DDWRST'?@(DDWLMAR-1_""" "".E") D
 . S DDWRST=$J("",DDWLMAR-1)_$$LD(DDWRST)
 S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)
 W $P(DDGLCLR,DDGLDEL)
 D ILINE
 S (DDWN,DDWL(DDWRW))=DDWRST
 ;
 I $G(DDWFLAG)=1 D
 . I $$SCR($L(DDWN)+1)=$P(DDWOFS,U,4) D
 .. D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 . D POS(DDWRW,"E","R")
 ;
 E  I '$G(DDWFLAG) D
 . I $P(DDWOFS,U,4)=1 D CUP(DDWRW,1) W $E(DDWN,1,IOM)
 . D POS(DDWRW,DDWLMAR,"R")
 ;
 E  D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 Q
 ;
ILINE ;Insert line below current line, make that current
 ;Column is unchanged
 N DDWI,DDWX
 I DDWRW<DDWMR D
 . I DDWA+DDWMR'>DDWCNT D
 .. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWMR)
 . F DDWI=DDWMR:-1:DDWRW+2 S DDWL(DDWI)=DDWL(DDWI-1)
 . S DDWL(DDWRW+1)=""
 . D CUP(DDWRW+1,1)
 . ;
 . I $P(DDGLED,DDGLDEL,3)]"" D
 .. I $P(DDGLED,DDGLDEL,2)="" D
 ... D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) D CUP(DDWRW+1,1)
 .. W $P(DDGLED,DDGLDEL,3)
 . E  D
 .. S DDWX=IOTM
 .. S IOTM=IOTM+DDWRW W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX
 .. D CUP(DDWRW+1,1) W $P(DDGLED,DDGLDEL)
 .. W @$P(DDGLED,DDGLDEL,2)
 . D POS(DDWRW+1,DDWC,"RN")
 ;
 E  D
 . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(1)
 . F DDWI=1:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1)
 . S DDWL(DDWMR)=""
 . D SCRUP^DDW3(1)
 S DDWCNT=DDWCNT+1
 S $E(DDWBF,1,3)=111
 Q
 ;
XLINE(DDWFLAG,DDWNP) ;Delete current line
 ;DDWFLAG:
 ; 1:leave cursor on deleted line (used by Join)
 ; 0:move cursor up one line if deleted line is last line
 ;   (used by PF1-D and DELBLK)
 ; DDWNP = 1:don't bother printing, used by DELBLK
 N DDWI,DDWX
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 F DDWI=DDWRW:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1)
 S DDWX="" S:DDWSTB DDWX=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1
 S DDWL(DDWMR)=DDWX
 ;
 D:'$G(DDWNP) XLINEP
 ;
 S DDWCNT=DDWCNT-1
 I 'DDWCNT D
 . S DDWCNT=1 D POS(1,DDWLMAR,"RN")
 E  I DDWA+DDWRW>DDWCNT,'$G(DDWFLAG) D
 . D UP^DDWT1
 E  D POS(DDWRW,DDWC,"N")
 S $E(DDWBF,1,3)=111
 Q
 ;
XLINEP ;Redisplay screen
 I $P(DDGLED,DDGLDEL,4)]"" D
 . W $P(DDGLED,DDGLDEL,4)
 . I $P(DDGLED,DDGLDEL,2)="" D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3)
 E  I DDWRW<DDWMR D
 . S DDWX=IOTM
 . S IOTM=IOTM+DDWRW-1 W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX
 . D CUP(DDWMR,1) W $C(10)
 . W @$P(DDGLED,DDGLDEL,2)
 E  D
 . D CUP(DDWMR,1) W $P(DDGLCLR,DDGLDEL)
 ;
 I DDWL(DDWMR)'?." " D
 . D CUP(DDWMR,1)
 . W $E(DDWL(DDWMR),1+DDWOFS,IOM+DDWOFS)
 Q
 ;
TR(X) Q:$G(X)="" X
 N I
 F I=$L(X):-1:0 Q:$E(X,I)'=" "
 Q $E(X,1,I)
 ;
LD(X) Q:$G(X)="" X
 N I
 F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
 Q $E(X,I,999)
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
SCR(C) ;
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)

DDW6
DDW6 ;SFISC/MKO-JOIN ;08:51 AM  31 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
REFMT ;Reformat
 N DDWRFMT
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 D POS(DDWRW,DDWLMAR,"R")
 S DDWRFMT=0 F  D JOIN Q:DDWRFMT
 Q
 ;
JOIN ;Join
 N DDWI,DDWSCR,DDWNSV,DDWLL,DDWTXT,DDWTXT0
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 ;
 ;Get current line
 S:DDWN?." " (DDWN,DDWL(DDWRW))=$J("",DDWLMAR-1)
 S (DDWTXT(1),DDWNSV)=DDWN
 ;
 ;Get next line
 I DDWRW=DDWMR S:DDWSTB DDWTXT(2)=^TMP("DDW1",$J,DDWSTB)
 E  S:DDWA+DDWRW<DDWCNT DDWTXT(2)=DDWL(DDWRW+1)
 ;
 I $G(DDWTXT(2))?." " D  Q:$G(DDWRFMT)
 . I $L(DDWN)>DDWRMAR S:$D(DDWTXT(2))#2 DDWLL=DDWTXT(2)
 . E  I $D(DDWRFMT) S DDWRFMT=1
 ;
 ;Adjust
 S DDWTXT0=$O(DDWTXT(""),-1)
 D ADJMAR(.DDWTXT,"","I")
 S:$D(DDWLL) DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=DDWLL
 S (DDWN,DDWL(DDWRW))=DDWTXT(1)
 ;
 ;Delete next line
 I DDWTXT0>1,DDWTXT=1 D
 . I DDWRW=DDWMR S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1,$E(DDWBF,1,3)=111
 . E  D POS(DDWRW+1,DDWC,"RN"),XLINE^DDW5(1),POS(DDWRW-1,DDWC,"RN")
 ;
 ;DDWSCR: curr scr = final scr
 I DDWTXT=1,'$D(DDWRFMT) D
 . S DDWSCR=$$SCR($L(DDWTXT(1))+1)=$P(DDWOFS,U,4)
 E  D
 . S DDWSCR=$$SCR(DDWLMAR)=$P(DDWOFS,U,4)
 ;
 I DDWSCR,$L(DDWNSV)'=$L(DDWN) D
 . D CUP(DDWRW,$$MIN($L(DDWNSV),$L(DDWN))+1-DDWOFS)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWN,$L(DDWNSV)+1,IOM+DDWOFS)
 ;
 I DDWTXT=1 D
 . I '$D(DDWRFMT) D
 .. D POS(DDWRW,"E","RN")
 . E  D POS(DDWRW,DDWLMAR,"RN")
 E  D JOIN2
 Q
 ;
JOIN2 ;Join produced >1 lines
 D POS(DDWRW,DDWLMAR,"R")
 ;
 I DDWTXT0=2 D
 . I DDWRW<DDWMR S DDWL(DDWRW+1)=DDWTXT(2)
 . E  S ^TMP("DDW1",$J,DDWSTB)=DDWTXT(2)
 . ;
 . I DDWRW<DDWMR D
 .. S DDWRW=DDWRW+1
 .. I DDWSCR D
 ... D CUP(DDWRW,1)
 ... W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWRW),1+DDWOFS,IOM+DDWOFS)
 . E  D MVFWD^DDW3(1)
 ;
 F DDWI=DDWTXT0+1:1:DDWTXT D
 . D ILINE^DDW5
 . S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
 . D CUP(DDWRW,1)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWN,1+DDWOFS,IOM+DDWOFS)
 ;
 D POS(DDWRW-($D(DDWLL)#2),DDWLMAR,"RN")
 Q
 ;
ADJMAR(DDWT,DDWW,DDWFLG) ;Adjust length of text in DDWT array
 ;  DDWT = Text array
 ;  DDWW = Width
 ;DDWFLG = I:First line $L=DDWRMAR, subsequent $L=DDWRMAR-DDWLMAR+1
 ;
 N DDWJ
 S DDWJ=1
 I $G(DDWFLG)["I" S DDWW=DDWRMAR
 E  I '$D(DDWW) S DDWW=DDWRMAR-DDWLMAR+1
 ;
 F  Q:'$D(DDWT(DDWJ))  D AMLOOP
 S DDWT=$O(DDWT(""),-1)
 I DDWLMAR>1 F DDWJ=$G(DDWFLG)["I"+1:1:DDWT D
 . S DDWT(DDWJ)=$J("",DDWLMAR-1)_DDWT(DDWJ)
 Q
 ;
AMLOOP ;Process DDWT(DDWJ)
 I $L(DDWT(DDWJ))>DDWW F  D  Q:$L(DDWT(DDWJ))'>DDWW
 . N DDWK,DDWFST,DDWLST
 . F DDWK=$O(DDWT(""),-1)+1:-1:DDWJ+2 S DDWT(DDWK)=DDWT(DDWK-1)
 . D SLICE(DDWT(DDWJ),DDWW,.DDWFST,.DDWLST)
 . S DDWT(DDWJ)=DDWFST,DDWT(DDWJ+1)=DDWLST
 . D AMINCJ
 ;
 E  I $L(DDWT(DDWJ))=DDWW!'$D(DDWT(DDWJ+1)) D
 . I DDWRAP,$D(DDWT(DDWJ+1)) S DDWT(DDWJ+1)=$$LD(DDWT(DDWJ+1))
 . D AMINCJ
 ;
 E  I 'DDWRAP D
 . N DDWK S DDWK=DDWW-$L(DDWT(DDWJ))
 . S DDWT(DDWJ)=DDWT(DDWJ)_$E(DDWT(DDWJ+1),1,DDWK)
 . S DDWT(DDWJ+1)=$E(DDWT(DDWJ+1),DDWK+1,999)
 . D:DDWT(DDWJ+1)="" AMSHIFT(.DDWT,DDWJ+1)
 ;
 E  D
 . N DDWD,DDWI
 . S DDWT(DDWJ+1)=$$LD(DDWT(DDWJ+1))
 . S:DDWT(DDWJ)'?.E1" " DDWT(DDWJ)=DDWT(DDWJ)_" "
 . S DDWD=0 F DDWI=1:1:$L(DDWT(DDWJ+1)," ") D  Q:DDWD
 .. I $L(DDWT(DDWJ))+$L($P(DDWT(DDWJ+1)," "))>DDWW S DDWD=1 Q
 .. ;
 .. S DDWT(DDWJ)=DDWT(DDWJ)_$P(DDWT(DDWJ+1)," ")
 .. S:$L(DDWT(DDWJ))<DDWW DDWT(DDWJ)=DDWT(DDWJ)_" "
 .. S DDWT(DDWJ+1)=$P(DDWT(DDWJ+1)," ",2,999)
 . ;
 . S DDWT(DDWJ)=$$TR(DDWT(DDWJ)),DDWT(DDWJ+1)=$$LD(DDWT(DDWJ+1))
 . I DDWT(DDWJ+1)="" D
 .. D AMSHIFT(.DDWT,DDWJ+1)
 . E  D:DDWI=1 AMINCJ
 Q
 ;
AMSHIFT(DDWT,DDWJ) ;Delete DDWT(DDWJ) and shift up
 N DDWI
 F DDWI=DDWJ:1:$O(DDWT(""),-1)-1 S DDWT(DDWI)=DDWT(DDWI+1)
 K DDWT($O(DDWT(""),-1))
 Q
 ;
AMINCJ ;Incr DDWJ
 I DDWJ=1,$G(DDWFLG)["I" S DDWW=DDWRMAR-DDWLMAR+1
 S DDWJ=DDWJ+1
 Q
 ;
SLICE(DDWN,DDWW,DDWFST,DDWRST) ;
 ;Out: DDWFST=first part of text, $L<=DDWRMAR (trailing bl removed)
 ;     DDWRST=remaining part (lead blanks removed)
 N DDWI,DDWX
 S:'$G(DDWW) DDWW=DDWRMAR
 ;
 I 'DDWRAP S DDWFST=$E(DDWN,1,DDWW),DDWLST=$E(DDWN,DDWW+1,999) Q
 ;
 F DDWI=$L(DDWN," "):-1:1 Q:$L($P(DDWN," ",1,DDWI))'>DDWW
 S:$E(DDWN,1,DDWI)?." " DDWI=999
 S DDWFST=$$TR($P(DDWN," ",1,DDWI))
 S:$L(DDWFST)>DDWW DDWFST=$E(DDWFST,1,DDWW)
 S DDWRST=$$LD($E(DDWN,$L(DDWFST)+1,999))
 Q
 ;
TR(X) Q:$G(X)="" X
 N I
 F I=$L(X):-1:0 Q:$E(X,I)'=" "
 Q $E(X,1,I)
 ;
LD(X) Q:$G(X)="" X
 N I
 F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
 Q $E(X,I,999)
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
SCR(C) ;Screen number
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)

DDW7
DDW7 ;SFISC/MKO-MARK TEXT ;09:09 AM  21 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
MARK ;Mark the text
 I $D(DDWMARK) D
 . D BOUND
 E  D
 . S DDWMARK=DDWA+DDWRW_U_DDWC_U_(DDWA+DDWRW)_U_$$MAX(DDWC,$L(DDWN))
 . D PAINT(DDWMARK,1),IND(1)
 Q
 ;
BOUND ;Mark ending boundary, highlight selected text
 N DDWI,DDWX,DDWY
 ;
 S DDWI=DDWA+DDWRW_U_DDWC
 S DDWX=$P(DDWMARK,U,1,2)
 S DDWY=$P(DDWMARK,U,3,4)
 ;
 I $$ISLESS(DDWI,DDWX) D
 . D PAINT(DDWX_U_DDWY)
 . D PAINT(DDWI_U_DDWX,1)
 . S DDWMARK=DDWI_U_DDWX
 E  D
 . I $$ISLESS(DDWI,DDWY) D
 .. D PAINT(DDWI_U_DDWY),PAINT(DDWI_U_DDWI,1)
 . E  D PAINT(DDWY_U_DDWI,1)
 . S DDWMARK=DDWX_U_DDWI
 D CUP(DDWRW,DDWC-DDWOFS)
 Q
 ;
UNMARK ;Unmark the text
 D:$D(DDWMARK) PAINT(DDWMARK),IND()
 K DDWMARK
 Q
 ;
PAINT(DDWMARK,DDWREV) ;Paint selected text
 N DDWI,DDWR1,DDWC1,DDWR2,DDWC2
 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2)
 S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4)
 ;
 W:$G(DDWREV) $P(DDGLVID,DDGLDEL,6)
 F DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR) D
 . D CUP(DDWI,$S(DDWI+DDWA=DDWR1:DDWC1-DDWOFS,1:1))
 . W $E(DDWL(DDWI),$S(DDWI+DDWA=DDWR1:DDWC1,1:1+DDWOFS),$$MIN($S(DDWI+DDWA=DDWR2:DDWC2,1:999),IOM+DDWOFS))
 W:$G(DDWREV) $P(DDGLVID,DDGLDEL,10)
 Q
 ;
IND(DDWX) ;Paint indicator
 S DY=$G(DDWBM,IOSL)-1,DX=IOM-7 X IOXY
 I $G(DDWX) D
 W $S($G(DDWX):$P(DDGLVID,DDGLDEL,6)_"Select"_$P(DDGLVID,DDGLDEL,10),1:$P(DDGLCLR,DDGLDEL))
 D CUP(DDWRW,DDWC-DDWOFS)
 Q
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
ISLESS(X,Y) ;Is coordinate X less than coordinate Y
 N R1,C1,R2,C2
 S R1=$P(X,U),C1=$P(X,U,2)
 S R2=$P(Y,U),C2=$P(Y,U,2)
 ;
 Q:R1>R2 0
 Q:R1<R2 1
 Q:C1>C2 0
 Q 1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDW8
DDW8 ;SFISC/MKO-COPY, CUT, PASTE ;10:39 AM  23 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
CUT() ;Cut selected text
 N DDWADJ,DDWC1,DDWC2,DDWCSV,DDWISIN,DDWNDEL,DDWR1,DDWR2,DDWRSV
 I '$D(DDWMARK) D ERR("No text selected.") Q
 ;
 S DDWISIN=$$ISINSEL()
 D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
 D COPYBUF
 ;
 S DDWRSV=DDWRW,DDWCSV=DDWC
 I DDWR2>DDWA,DDWR2-DDWA<DDWRW S DDWADJ=1
 E  I DDWR1-DDWA'>DDWMR,DDWR1-DDWA>DDWRW S DDWADJ=0
 ;
 D DELBLK^DDW9(.DDWNDEL)
 D:$D(DDWADJ) POS(DDWRSV-(DDWADJ*DDWNDEL),DDWCSV,"RN")
 D:'DDWISIN PASTE()
 Q
 ;
COPY() ;Copy selected text
 N DDWC1,DDWC2,DDWISIN,DDWR1,DDWR2
 I '$D(DDWMARK) D ERR("No text selected.") Q
 ;
 S DDWISIN=$$ISINSEL()
 D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
 D COPYBUF
 D UNMARK^DDW7
 D:'DDWISIN PASTE()
 Q
 ;
COPYBUF ;Copy selected text to buffer
 N DDWND,DDWI,DDWX,DDWX1,DDWX2
 K ^TMP("DDWB",$J)
 S DDWND=0
 ;
 D:DDWR2-DDWR1>50 MSG^DDW("Copying text to buffer ...")
 ;
 F DDWI=DDWR1:1:$$MIN(DDWA,DDWR2) D
 . S DDWND=DDWND+1
 . S DDWX=^TMP("DDW",$J,DDWI)
 . S DDWX=$E(DDWX,$S(DDWI=DDWR1:DDWC1,1:1),$S(DDWI=DDWR2:DDWC2,1:999))
 . S ^TMP("DDWB",$J,DDWND)=DDWX
 ;
 F DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR) D
 . S DDWX=$E(DDWL(DDWI),$S(DDWI+DDWA=DDWR1:DDWC1,1:1),$S(DDWI+DDWA=DDWR2:DDWC2,1:999))
 . S DDWND=DDWND+1
 . S ^TMP("DDWB",$J,DDWND)=DDWX
 ;
 S DDWX1=$$RTOSTB(DDWR1),DDWX2=$$RTOSTB(DDWR2)
 F DDWI=$$MIN(DDWSTB,DDWX1):-1:DDWX2 D
 . S DDWND=DDWND+1
 . S DDWX=^TMP("DDW1",$J,DDWI)
 . S DDWX=$E(DDWX,$S(DDWI=DDWX1:DDWC1,1:1),$S(DDWI=DDWX2:DDWC2,1:999))
 . S ^TMP("DDWB",$J,DDWND)=DDWX
 ;
 D:DDWR2-DDWR1>50 MSG^DDW()
 Q
 ;
PASTE() ;Paste text
 I $D(DDWMARK) D ERR("You curently have text selected.") Q
 I '$D(^TMP("DDWB",$J)) D ERR("The buffer contains no text.") Q
 ;
 N DDWBSIZ,DDWFC,DDWI,DDWLST,DDWNSV,DDWTXT,DDWX
 S DDWBSIZ=$O(^TMP("DDWB",$J,""),-1)
 ;
 S DDWTXT=1
 S:$L(DDWN)+1<DDWC DDWN=DDWN_$J("",DDWC-$L(DDWN)-1)
 S (DDWNSV,DDWX)=$E(DDWN,1,DDWC-1)
 S DDWTXT(1)=DDWX
 I $L(DDWX)+$L(^TMP("DDWB",$J,1))<256!(DDWX="") S DDWTXT(1)=DDWTXT(1)_^(1)
 E  S DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=^TMP("DDWB",$J,1)
 ;
 S DDWLST=$E(DDWN,DDWC,999)
 I DDWRAP,DDWLST?1." " S DDWLST=""
 I DDWLST]"",DDWBSIZ=1 S DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=DDWLST,DDWLST=""
 ;
 D:DDWTXT ADJMAR^DDW6(.DDWTXT,"","I")
 S (DDWN,DDWL(DDWRW))=DDWTXT(1)
 ;
 I DDWBSIZ=1,DDWTXT=1 S DDWFC=$L(DDWNSV)+$L(^TMP("DDWB",$J,1))+1
 E  I DDWBSIZ=1,DDWTXT=2,DDWLST="" S DDWFC=$L(DDWTXT(2))+1
 E  S DDWFC=1
 ;
 I $$SCR(DDWFC)=$P(DDWOFS,U,4) D
 . D POS(DDWRW,$$MIN($L(DDWNSV),$L(DDWN))+1)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWN,$L(DDWNSV)+1,IOM+DDWOFS)
 ;
 D POS(DDWRW,DDWFC,"R")
 ;
 F DDWI=2:1:DDWTXT D
 . D ILINE^DDW5
 . S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI)
 . D CUP(DDWRW,1)
 . W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 ;
 F DDWI=2:1:DDWBSIZ D
 . D ILINE^DDW5
 . S (DDWN,DDWL(DDWRW))=^TMP("DDWB",$J,DDWI)
 . D CUP(DDWRW,1)
 . W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 ;
 I DDWLST]"" D
 . D ILINE^DDW5
 . S (DDWN,DDWL(DDWRW))=DDWLST
 . D CUP(DDWRW,1)
 . W $E(DDWN,1+DDWOFS,IOM+DDWOFS)
 ;
 D POS(DDWRW,DDWFC,"RN")
 Q
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
ISINSEL() ;Is the cursor within the selected text
 N DDWI,DDWY
 S DDWI=DDWRW+DDWA,DDWY=0
 I DDWI<$P(DDWMARK,U)
 E  I DDWI>$P(DDWMARK,U,3)
 E  I DDWI=$P(DDWMARK,U),DDWC<$P(DDWMARK,U,2)
 E  I DDWI=$P(DDWMARK,U,3),DDWC-1>$P(DDWMARK,U,4)
 E  S DDWY=1
 Q DDWY
 ;
PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK)
 S R1=$P(M,U),C1=$P(M,U,2)
 S R2=$P(M,U,3),C2=$P(M,U,4)
 Q
 ;
ERR(DDWX) ;
 D MSG^DDW($C(7)_DDWX) H 2 D MSG^DDW()
 D CUP(DDWRW,DDWC-DDWOFS)
 F  R *DDWX:0 E  Q
 Q
 ;
TR(X) ;Strip trailing blanks
 Q:$G(X)="" X
 N I
 F I=$L(X):-1:0 Q:$E(X,I)'=" "
 Q $E(X,1,I)
 ;
LD(X) ;Strip leading blanks
 Q:$G(X)="" X
 N I
 F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
 Q $E(X,I,999)
 ;
RTOSTB(R) ;Return node in STB given line #
 Q DDWSTB+DDWA+DDWMR+1-R
 ;
SCR(C) ;Return screen number
 Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDW9
DDW9 ;SFISC/MKO-MARK TEXT ;10:10 AM  17 May 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
CHKDEL(DDWY) ;Check that cursor is on block and delete
 N DDWI
 N DDWC1,DDWC2,DDWR1,DDWR2,DDWI
 D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
 S DDWY=0,DDWI=DDWRW+DDWA
 Q:DDWI<DDWR1
 Q:DDWI>DDWR2
 I DDWI=DDWR1,DDWC<DDWC1 D UNMARK^DDW7 Q
 I DDWI=DDWR2,DDWC-1>DDWC2 D UNMARK^DDW7 Q
 ;
 D DELBLK()
 S DDWY=1
 Q
 ;
DELBLK(DDWNDEL) ;Delete block
 ;Returns: DDWNDEL=# lines deleted from the screen
 N DDWNP,DDWI,DDWX
 I '$D(DDWR1) N DDWR1,DDWR2,DDWC1,DDWC2 D
 . D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2)
 ;
 S DDWNDEL=0,$E(DDWBF,1,3)=111
 K DDWMARK
 ;
 I DDWR2-DDWA<1 D
 . D DELABV
 E  I DDWR1-DDWA>DDWMR D
 . D DELBEL
 E  D DELMID
 ;
 D IND^DDW7()
 Q
 ;
DELABV ;All of the block is above the screen
 I DDWR1=DDWR2 D  Q
 . N DDWX
 . S DDWX=^TMP("DDW",$J,DDWR1),$E(DDWX,DDWC1,DDWC2)=""
 . I DDWX]"" S ^TMP("DDW",$J,DDWR1)=DDWX
 . E  D SHIFTA(DDWR1,DDWR1)
 ;
 D:DDWR2-DDWR1>50 MSG^DDW("Deleting selected text.")
 N DDWFST,DDWLST
 S DDWFST=$E(^TMP("DDW",$J,DDWR1),1,DDWC1-1)
 S DDWLST=$E(^TMP("DDW",$J,DDWR2),DDWC2+1,999)
 I DDWFST]"" S ^TMP("DDW",$J,DDWR1)=DDWFST,DDWFST=DDWR1+1
 E  S DDWFST=DDWR1
 I DDWLST]"" S ^TMP("DDW",$J,DDWR2)=DDWLST,DDWLST=DDWR2-1
 E  S DDWLST=DDWR2
 D SHIFTA(DDWFST,DDWLST)
 D:DDWR2-DDWR1>50 MSG^DDW()
 Q
 ;
SHIFTA(DDWA1,DDWA2) ;
 N DDWNL
 S DDWNL=DDWA2-DDWA1+1
 I DDWA2=DDWA S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q
 ;
 N DDWI
 F DDWI=DDWA1:1:DDWA-DDWNL S ^TMP("DDW",$J,DDWI)=^TMP("DDW",$J,DDWI+DDWNL)
 S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL
 Q
 ;
DELBEL ;All of the block is below the screen
 N DDWS1,DDWS2
 S DDWS1=DDWA+DDWMR+DDWSTB-DDWR1+1,DDWS2=DDWA+DDWMR+DDWSTB-DDWR2+1
 I DDWS1=DDWS2 D  Q
 . N DDWX
 . S DDWX=^TMP("DDW1",$J,DDWS1),$E(DDWX,DDWC1,DDWC2)=""
 . I DDWX]"" S ^TMP("DDW1",$J,DDWS1)=DDWX
 . E  D SHIFTB(DDWS1,DDWS1)
 ;
 D:DDWR2-DDWR1>50 MSG^DDW("Deleting selected text.")
 N DDWFST,DDWLST
 S DDWFST=$E(^TMP("DDW1",$J,DDWS1),1,DDWC1-1)
 S DDWLST=$E(^TMP("DDW1",$J,DDWS2),DDWC2+1,999)
 I DDWFST]"" S ^TMP("DDW1",$J,DDWS1)=DDWFST,DDWFST=DDWS1-1
 E  S DDWFST=DDWS1
 I DDWLST]"" S ^TMP("DDW1",$J,DDWS2)=DDWLST,DDWLST=DDWS2+1
 E  S DDWLST=DDWS2
 D SHIFTB(DDWFST,DDWLST)
 D:DDWR2-DDWR1>50 MSG^DDW()
 Q
 ;
SHIFTB(DDWS1,DDWS2) ;
 N DDWNL
 S DDWNL=DDWS1-DDWS2+1
 I DDWS1=DDWSTB S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q
 ;
 N DDWI
 F DDWI=DDWS2:1:DDWSTB-DDWNL S ^TMP("DDW1",$J,DDWI)=^TMP("DDW1",$J,DDWI+DDWNL)
 S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL
 Q
 ;
DELMID ;A portion of the block appears on the screen
 I DDWR2-1-DDWA>DDWMR D
 . S DDWX=DDWR2-(DDWA+DDWMR+1)
 . S DDWSTB=DDWSTB-DDWX,DDWCNT=DDWCNT-DDWX
 ;
 I DDWR2-DDWA>DDWMR D
 . S DDWX=$E(^TMP("DDW1",$J,DDWSTB),DDWC2+1,999)
 . I DDWX="" S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1
 . E  S ^TMP("DDW1",$J,DDWSTB)=DDWX
 ;
 D POS($$MAX(DDWR1-DDWA,1),$S(DDWR1=DDWR2:DDWC1,1:1),"RN")
 ;
 S DDWNP=DDWR2-DDWA'<DDWMR
 F DDWI=DDWRW:1:$$MIN(DDWR2-DDWA,DDWMR) D
 . S DDWX=$E(DDWL(DDWRW),1,$S(DDWI+DDWA=DDWR1:DDWC1,1:1)-1)_$E(DDWL(DDWRW),$S(DDWI+DDWA=DDWR2:DDWC2,1:999)+1,999)
 . I DDWX]"" D
 .. S DDWL(DDWRW)=DDWX
 .. I 'DDWNP D
 ... D CUP(DDWRW,1)
 ... W $P(DDGLCLR,DDGLDEL)_$E(DDWX,1+DDWOFS,IOM+DDWOFS)
 .. D POS(DDWRW+(DDWI<$$MIN(DDWR2-DDWA,DDWMR)),DDWC,"RN")
 . E  D XLINE^DDW5(1,DDWNP) S DDWNDEL=DDWNDEL+1
 ;
 I DDWNP F DDWI=$$MAX(DDWR1-DDWA,1):1:DDWMR D
 . D CUP(DDWI,1)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 ;
 I DDWR1+1'>DDWA D
 . S DDWX=DDWA-DDWR1
 . S DDWA=DDWA-DDWX,DDWCNT=DDWCNT-DDWX
 ;
 I DDWR1'>DDWA D
 . S DDWX=$E(^TMP("DDW",$J,DDWA),1,DDWC1-1)
 . I DDWX="" S DDWA=DDWA-1,DDWCNT=DDWCNT-1
 . E  S ^TMP("DDW",$J,DDWA)=DDWX
 ;
 S:DDWCNT<1 DDWCNT=1
 D:DDWRW+DDWA>DDWCNT UP^DDWT1
 Q
 ;
PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK)
 S R1=$P(M,U),C1=$P(M,U,2)
 S R2=$P(M,U,3),C2=$P(M,U,4)
 Q
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDWC
DDWC ;SFISC/MKO-CHANGE (REPLACE) ;09:24 AM  27 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CHG ;Change
 N DDWOPT
 D SETUP^DDWC1
 F  D PROC Q:DDWOPT=-1
 D RESTORE^DDWC1
 K DDWCHG(1)
 Q
 ;
PROC ;Main procedure
 N DDWCOD,DDWT
 ;
 D:$D(DDWMARK) UNMARK^DDW7
 D EN^DIR0(IOTM+DDWMR,14,30,"",$G(DDWFIND),100,"","","AKTW",.DDWT,.DDWCOD)
 I DDWT=""!(DDWCOD="TO") S DDWOPT=-1 Q
 S DDWFIND=DDWT,DDWT=$$UC(DDWT)
 ;
 K DDWCHG(1)
 D EN^DIR0(IOTM+DDWMR+1,14,30,"",$G(DDWCHG),100,"","","AKTW",.DDWCHG,.DDWCOD)
 I DDWCOD="TO" S DDWOPT=-1 Q
 S:DDWCHG?1L.E DDWCHG(1)=$$UC($E(DDWCHG))_$E(DDWCHG,2,999)
 ;
 F  D OPT Q:DDWOPT]""
 Q
 ;
OPT ;Prompt for and process option
 W $P(DDGLVID,DDGLDEL,6)
 F  D  Q:DDWOPT]""
 . D CUP(DDWMR+4,15) W " "_$C(8)
 . R DDWOPT#1:DTIME E  S DDWOPT="Q" Q
 . I DDWOPT=U S DDWOPT="Q"
 . I DDWOPT="" S DDWOPT="E" Q
 . I DDWOPT="?" S DDWOPT="H" Q
 . S DDWOPT=$$UC(DDWOPT)
 . I "^F^R^A^Q^"'[(U_DDWOPT_U) W $C(7) S DDWOPT=""
 D CUP(DDWMR+4,15) W $P(DDGLVID,DDGLDEL,10)_" "
 D @DDWOPT
 Q
 ;
F ;Find next
 D FINDT^DDWF(DDWFIND)
 S DDWOPT=""
 Q
 ;
R ;Replace
 N DDWE
 I '$D(DDWMARK) D CERR Q
 D RS(.DDWE) Q:$G(DDWE)
 D F
 Q
 ;
RS(DDWE) ;Change selected text
 N DDWDIF
 S DDWDIF=$L(DDWCHG)-$P(DDWMARK,U,4)+$P(DDWMARK,U,2)-1
 I $L(DDWN)+DDWDIF>245 D  Q
 . S DDWE=1,DDWOPT=""
 . D MSG($C(7)_"Unable to change text.  Resultant line is too long.")
 ;
 S DDWE=0
 S $E(DDWN,$P(DDWMARK,U,2),$P(DDWMARK,U,4))=$S($E(DDWN,$P(DDWMARK,U,2))?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG)
 S DDWL(DDWRW)=DDWN
 D CUP(DDWRW,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWN,1+DDWOFS,IOM+DDWOFS)
 K DDWMARK D IND^DDW7()
 D POS(DDWRW,DDWC+DDWDIF,"R")
 Q
 ;
A ;Change all
 N DDWE,DDWF,DDWI,DDWND,DDWX
 D MSG^DDW("Changing text ...")
 I $D(DDWMARK) D RS(.DDWE) G:$G(DDWE) AEND
 ;
 S DDWX=$F($$UC(DDWL(DDWRW)),DDWT,DDWC)
 I DDWX D
 . S DDWL(DDWRW)=$$REP(DDWL(DDWRW),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
 . S:$G(DDWE) DDWE=DDWRW+DDWA_U_DDWE
 ;
 I '$G(DDWE) F DDWI=DDWRW+1:1:DDWMR D  Q:$G(DDWE)
 . S DDWX=$F($$UC(DDWL(DDWI)),DDWT)
 . S:DDWX DDWL(DDWI)=$$REP(DDWL(DDWI),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
 . S:$G(DDWE) DDWE=DDWI+DDWA_U_DDWE
 ;
 I '$G(DDWE) F DDWI=DDWSTB:-1:1 D  Q:$G(DDWE)
 . S DDWND=^TMP("DDW1",$J,DDWI)
 . S DDWX=$F($$UC(DDWND),DDWT)
 . S:DDWX ^TMP("DDW1",$J,DDWI)=$$REP(DDWND,DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1
 . S:$G(DDWE) DDWE=DDWA+DDWMR+DDWSTB-DDWI+1_U_DDWE
 ;
 I $G(DDWF) D
 . D:$G(DDWE) MSG^DDW($C(7)_"Unable to complete replacement.  A resultant line is too long.") H 2
 . F DDWI=1:1:$$MIN(DDWMR,DDWCNT-DDWA) D
 .. D CUP(DDWI,1)
 .. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 . D:$G(DDWE) LINE^DDWG(+DDWE,1),POS(DDWRW,$P(DDWE,U,2),"R")
 E  D MSG^DDW("Text not found.") H 2 D FLUSH
 ;
AEND D MSG^DDW(),CUP(DDWRW,DDWC)
 S DDWOPT=$S($G(DDWE):-1,1:"")
 Q
 ;
REP(DDWND,DDWFIND,DDWCHG,DDWX,DDWE) ;String replacement of DDWND
 N DDWDIF,DDWFST,DDWSV
 S DDWDIF=$L(DDWCHG)-$L(DDWFIND)
 F  D  Q:'DDWX!$G(DDWE)
 . S DDWSV=DDWND,DDWFST=DDWX-$L(DDWFIND)
 . I $L(DDWND)+DDWDIF>245 S DDWE=DDWFST Q
 . S $E(DDWND,DDWFST,DDWX-1)=$S($E(DDWND,DDWFST)?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG)
 . S DDWX=DDWX+DDWDIF
 . S DDWX=$F($$UC(DDWND),DDWFIND,DDWX)
 Q $S($G(DDWE):DDWSV,1:DDWND)
 ;
E ;Edit Find
 D FLUSH
 Q
 ;
Q ;Quit option
 D FLUSH
 S DDWOPT=-1
 Q
 ;
H ;Help
 D MSG("Press the highlighted letter of one of the Options.")
 S DDWOPT=""
 Q
 ;
CERR ;The Change options are disabled
 D MSG($C(7)_"You must Find the text before you can Change it.")
 S DDWOPT=""
 Q
 ;
MSG(DDWX) ;
 D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)_$G(DDWX) H 2
 D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)
 D FLUSH
 Q
 ;
FLUSH ;Flush read buffer
 N DDWX F  R *DDWX:0 E  Q
 Q
 ;
UC(X) ;Return uppercase of X
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
CUP(Y,X) ;Pos cursor
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q

DDWC1
DDWC1 ;SFISC/MKO-CHANGE ;09:20 AM  27 Aug 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SETUP ;Setup new scrolling region
 N DDWI
 F DDWI=$$MIN(DDWMR,DDWCNT-DDWA):-1:DDWMR-4 D
 . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI)
 S IOBM=IOBM-5,DDWMR=DDWMR-5
 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2)
 ;
 ;Print dialog box
 N DDWR0,DDWR1
 S DDWR1=$P(DDGLVID,DDGLDEL,6),DDWR0=$P(DDGLVID,DDGLDEL,10)
 ;
 D CUP(DDWMR+1,1)
 W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2),!
 D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_"   Find What:"
 D CUP(DDWMR+3,1) W $P(DDGLCLR,DDGLDEL)_"Replace With: "_$G(DDWCHG)
 D CUP(DDWMR+4,1) W $P(DDGLCLR,DDGLDEL)_"      Option:"_$P(DDGLCLR,DDGLDEL)_$J("",20)_DDWR1_"F"_DDWR0_"ind Next   "_DDWR1_"R"_DDWR0_"eplace   Replace "_DDWR1_"A"_DDWR0_"ll   "_DDWR1_"Q"_DDWR0_"uit"
 D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)
 Q
 ;
RESTORE ;Restore original scrolling region
 N DDWI
 S IOBM=IOBM+5,DDWMR=DDWMR+5
 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2)
 F DDWI=DDWMR-4:1:DDWMR D
 . I DDWI+DDWA'>DDWCNT D
 .. S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1
 . E  S DDWL(DDWI)=""
 . D CUP(DDWI,1)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 .
 D POS(DDWRW,DDWC,"RN")
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
CUP(Y,X) ;Pos cursor
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q

DDWF
DDWF ;SFISC/MKO-FIND, REPLACE ;08:31 AM  22 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
NEXT ;Find next occurrence of same text
 N DDWT
 G:$G(DDWFIND)="" FIND
 S DDWT=DDWFIND
 D FINDT(DDWT,$G(DDWFIND(1)))
 Q
 ;
FIND ;Prompt and find text
 N DDWCOD,DDWF,DDWT
 D ASK^DDWG(3,"Find What: ",30,$G(DDWFIND),"","",.DDWT,.DDWCOD)
 Q:DDWT=""
 D FINDT(DDWT,$P($G(DDWCOD),U)="U")
 Q
 ;
FINDT(DDWT,DDWBACK) ;Find DDWT
 D:$D(DDWMARK) UNMARK^DDW7
 S DDWFIND=DDWT,DDWT=$$UC(DDWT)
 I $G(DDWBACK) D
 . S DDWFIND(1)=1 D LOOKB
 E  K DDWFIND(1) D LOOK
 Q
 ;
LOOK ;Look in arrays
 N DDWF,DDWI,DDWX
 S DDWF=$F($$UC(DDWL(DDWRW)),DDWT,DDWC)
 I DDWF D REPOS(DDWRW+DDWA,DDWF) Q
 ;
 F DDWI=DDWRW+1:1:DDWMR D  Q:DDWF
 . S DDWX=$F($$UC(DDWL(DDWI)),DDWT)
 . I DDWX D REPOS(DDWI+DDWA,DDWX) S DDWF=1
 Q:DDWF
 ;
 D MSG^DDW("Searching ...")
 F DDWI=DDWSTB:-1:1 D  Q:DDWF
 . S DDWX=$F($$UC(^TMP("DDW1",$J,DDWI)),DDWT)
 . I DDWX D
 .. D MSG^DDW()
 .. D REPOS(DDWA+DDWMR+DDWSTB-DDWI+1,DDWX)
 .. S DDWF=1
 Q:DDWF
 ;
 D MSG^DDW("Text not found.") H 2
 D MSG^DDW(),CUP(DDWRW,DDWC)
 F  R *DDWX:0 E  Q
 Q
 ;
LOOKB ;Look backward in arrays
 N DDWF,DDWI,DDWX
 S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-1),DDWT)
 I DDWF=DDWC S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-$L(DDWT)-1),DDWT)
 I DDWF D REPOS(DDWRW+DDWA,DDWF) Q
 ;
 F DDWI=DDWRW-1:-1:1 D  Q:DDWF
 . S DDWX=$$RF($$UC(DDWL(DDWI)),DDWT)
 . I DDWX D REPOS(DDWI+DDWA,DDWX) S DDWF=1
 Q:DDWF
 ;
 D MSG^DDW("Searching ...")
 F DDWI=DDWA:-1:1 D  Q:DDWF
 . S DDWX=$$RF($$UC(^TMP("DDW",$J,DDWI)),DDWT)
 . I DDWX D
 .. D MSG^DDW()
 .. D REPOS(DDWI,DDWX)
 .. S DDWF=1
 Q:DDWF
 ;
 D MSG^DDW("Text not found.") H 2
 D MSG^DDW(),CUP(DDWRW,DDWC)
 F  R *DDWX:0 E  Q
 Q
 ;
REPOS(DDWY,DDWX) ;Define DDWMARK, paint if on screen
 S DDWMARK=DDWY_U_(DDWX-$L(DDWT))_U_DDWY_U_(DDWX-1)
 I DDWY-DDWA>0,DDWY-DDWA'>DDWMR,DDWX-DDWOFS>0,DDWX-DDWOFS'>IOM D
 . D PAINT^DDW7(DDWMARK,1)
 . D POS(DDWY-DDWA,DDWX,"RN")
 E  D LINE^DDWG(DDWY,DDWX)
 D IND^DDW7(1)
 Q
 ;
UC(X) ;Return uppercase of X
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;
RF(X,T) ;Find last occurrence of T in X
 N Y
 Q:X'[T 0
 S Y=1 F  S Y=$F(X,T,Y) Q:'$F(X,T,Y)
 Q Y
 ;
CUP(Y,X) ;Cursor positioning
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q

DDWG
DDWG ;SFISC/MKO-GOTO ;09:03 AM  23 Jun 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
GOTO ;Go to a specific location
 N DDWANS,DDWI,DDWHLP
 S DDWHLP(1)="Examples, to go to a screen:  S21, 21, S+3, +3, -3"
 S DDWHLP(2)="          to go to a line:    L53, L+4, L-5"
 S DDWHLP(3)="          to go to a column:  C40, C+10, C-20"
 D ASK(4,"Go to: ",17,"","D VALGTO",.DDWHLP,.DDWANS)
 I U[DDWANS
 E  I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D
 . D GOTOS
 E  I "Ll"[$E(DDWANS) D
 . D GOTOL
 E  I "Cc"[$E(DDWANS) D
 . D GOTOC
 Q
 ;
GOTOS ;Go to a page
 N DDWS
 S DDWS=DDWANS
 S:DDWS?1A.E DDWS=$E(DDWS,2,999)
 S:DDWS?1P.E DDWS=$E(DDWS,2,999)
 I DDWANS["+" S DDWS=$$SCREEN+DDWS
 E  I DDWANS["-" S DDWS=$$SCREEN-DDWS
 I DDWS<1 S DDWS=1
 E  I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT)
 D LINE(DDWS-1*DDWMR+1)
 Q
 ;
GOTOL ;Go to a line
 N DDWLN
 S DDWLN=DDWANS
 S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999)
 S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999)
 I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN
 E  I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN
 I DDWLN<1 S DDWLN=1
 E  I DDWLN>DDWCNT S DDWLN=DDWCNT
 D LINE(DDWLN)
 Q
 ;
GOTOC ;Go to a column
 N DDWCOL
 S DDWCOL=DDWANS
 S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999)
 S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999)
 I DDWANS["+" S DDWCOL=DDWC+DDWCOL
 E  I DDWANS["-" S DDWCOL=DDWC-DDWCOL
 I DDWCOL<1 S DDWCOL=1
 E  I DDWCOL>246 S DDWCOL=246
 D POS(DDWRW,DDWCOL,"R")
 Q
 ;
LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN
 I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1
 S:DDWLN>DDWCNT DDWLN=DDWCNT
 I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D
 . D POS(DDWLN-DDWA,DDWCOL,"RN")
 E  I DDWLN>DDWA D
 . D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN")
 E  D
 . D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN")
 Q
 ;
ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user
 N DDWI
 D CUP(DDWMR-DDWLC,1)
 W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2)
 F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL)
 K DDWANS F  D PROMPT Q:$D(DDWANS)
 ;
 F DDWI=DDWMR-DDWLC:1:DDWMR D
 . D CUP(DDWI,1)
 . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 D POS(DDWRW,DDWC,"RN")
 Q
 ;
PROMPT ;Issue read
 N DDWERR,DDWX
 D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL)
 D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)
 ;
 I DDWCOD="TO" W $C(7) Q
 I U[DDWX S DDWANS=DDWX Q
 I $D(DDWHLP)>9!($G(DDWHLP)]""),DDWX?1."?" D HELP(.DDWHLP) Q
 I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q
 S DDWANS=DDWX
 Q
 ;
VALGTO ;Validate DDWX
 N DDWCH
 Q:DDWX=U
 S DDWERR="Invalid format.  Enter ? for examples."
 Q:DDWX'?.1A.1P1.15N
 I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH
 I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q
 K DDWERR
 Q
 ;
HELP(DDWMSG) ;Print message
 N DDWI,DDWEC
 S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG
 S DDWEC=$O(DDWMSG(""),-1)
 F DDWI=2:1:DDWLC D
 . D CUP(DDWMR-DDWLC+DDWI,1)
 . W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC))
 Q
 ;
SCREEN() ;Return current screen
 Q DDWA+DDWRW-1\DDWMR+1
 ;
LTOSC(L) ;Convert line number to page number
 Q L-1\DDWMR+1
 ;
CUP(Y,X) ;Pos cursor
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor based on char pos C
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q

DDWH
DDWH ;SFISC/MKO-SCREEN EDITOR HELP ;08:38 AM  23 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
HLP ;
 N DX,DY,DDWI
 ;
 D HLP^DDGLIBH(9211,9214,"DDWH",IOBM+2)
 D BOX^DDW1
 ;
 S DY=IOTM-1,DX=0 X IOXY
 F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI<DDWMR:$C(13,10),1:"")
 ;
 D:$D(DDWMARK) IND^DDW7(1)
 Q
 ;
LINE(DDWI,DDWMARK) ;
 N DDWX
 S DDWX=$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
 Q:$G(DDWMARK)="" DDWX
 ;
 N DDWR1,DDWC1,DDWR2,DDWC2
 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2)
 S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4)
 ;
 I DDWI'<(DDWR1-DDWA),DDWI'>(DDWR2-DDWA) D
 . N DDWX1,DDWX2
 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1)
 . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999)
 . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS)
 Q DDWX
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)
 ;
MAX(X,Y) ;
 Q $S(X>Y:X,1:Y)

DDWK
DDWK ;SFISC/MKO-SCREEN EDITOR MAIN ROUTINE ;1:04 PM  18 Oct 1995
 ;;21.0;VA FileMan;**11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
GETKEY ;Get key sequences and defaults
 N AU,AD,AR,AL,F1,F2,F3,F4
 N FIND,REMOVE,PREVSC,NEXTSC
 N I,K,N,T
 S AU=$P(DDGLKEY,U,2)
 S AD=$P(DDGLKEY,U,3)
 S AR=$P(DDGLKEY,U,4)
 S AL=$P(DDGLKEY,U,5)
 S F1=$P(DDGLKEY,U,6)
 S F2=$P(DDGLKEY,U,7)
 S F3=$P(DDGLKEY,U,8)
 S F4=$P(DDGLKEY,U,9)
 S FIND=$P(DDGLKEY,U,10)
 S REMOVE=$P(DDGLKEY,U,13)
 S PREVSC=$P(DDGLKEY,U,14)
 S NEXTSC=$P(DDGLKEY,U,15)
 ;
 S DDW("IN")="",DDW("OUT")=""
 F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T=""  D
 . S @("K="_$P(T,";",2))
 . I DDW("IN")'[(U_K),K]"" D
 .. S DDW("IN")=DDW("IN")_U_K
 .. S DDW("OUT")=DDW("OUT")_$P(T,";")_U
 S DDW("IN")=DDW("IN")_U
 S DDW("OUT")=$E(DDW("OUT"),1,$L(DDW("OUT"))-1)
 Q
 ;
MAP ;Keys for main screen
 ;;UP;AU
 ;;DN;AD
 ;;RT;AR
 ;;LT;AL
 ;;TAB;$C(9)
 ;;PUP;F1_AU
 ;;PUP;PREVSC
 ;;PDN;F1_AD
 ;;PDN;NEXTSC
 ;;JLT;F1_AL
 ;;JRT;F1_AR
 ;;LB;F1_F1_AL
 ;;LE;F1_F1_AR
 ;;TOP;F1_"T"
 ;;BOT;F1_"B"
 ;;WRT;F1_" "
 ;;WRT;$C(12)
 ;;WLT;$C(10)
 ;;RUB;$C(127)
 ;;RUB;$C(8)
 ;;DEL;REMOVE
 ;;DEL;F4
 ;;DEOL;F1_F2
 ;;BRK;$C(13)
 ;;JN;F1_"J"
 ;;RFT;F1_"R"
 ;;ST;F1_"?"
 ;;XLN;F1_"D"
 ;;TST;F1_$C(9)
 ;;LST;F1_","
 ;;RST;F1_"."
 ;;WRM;F2
 ;;RPM;F3
 ;;SV;F1_"S"
 ;;SW;F1_"A"
 ;;EX;F1_"E"
 ;;QT;F1_"Q"
 ;;HLP;F1_"H"
 ;;DLW;$C(23)
 ;;MRK;F1_"M"
 ;;UMK;F1_F1_"M"
 ;;CUT;F1_"X"
 ;;CPY;F1_"C"
 ;;PST;F1_"V"
 ;;FND;F1_"F"
 ;;FND;FIND
 ;;NXT;F1_"N"
 ;;GTO;F1_"G"
 ;;CHG;F1_"P"
 ;;';$C(27)_"Q"
 ;;';$C(27)_"R"
 ;;";$C(27)_"S"
 ;;";$C(27)_"T"
 ;;

DDWT1
DDWT1 ;SFISC/PD KELTZ,MKO-READ AND PROCESS ;02:14 PM  12 Feb 1996
 ;;21.0;VA FileMan;**4,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D LOAD^DDW1
 F  D GETIN Q:$D(DDWFIN)
 Q
 ;
GETIN ;Get input
 I DDWC'>DDWRMAR,DDWC-DDWOFS<IOM,DDWC>$L(DDWN)!DDWREP,'$D(DDWMARK) D
 . N DDWANS
 . D PREAD($$MIN(DDWRMAR,IOM-1+DDWOFS)-DDWC+1,DDWTO,.DDWANS,.DDWQ)
 . I DDWANS]"" D
 .. S:DDWQ="TO" DDWQ=""
 .. S $E(DDWN,DDWC,DDWC+$L(DDWANS)-1)=DDWANS,DDWL(DDWRW)=DDWN
 .. S DDWC=DDWC+$L(DDWANS)
 E  D
 . D READ(DDWTO,.DDWQ)
 . D:$L(DDWQ)=1 DISPL
 ;
 I DDWQ'="TO" K DDWTC
 E  D
 . S DDWTC=$G(DDWTC)+1
 . S:DDWTC<(DTIME\DDWTO) DDWQ=""
 . I DDWSTAT,DDWTC=1,$L(DDWQ)'>1 D STATUS
 ;
 I $L(DDWQ)>1 D @DDWQ I DDWSTAT D STATUS S DDWTC=1
 Q
 ;
DISPL ;Display char
 I DDWC>245 W $C(7) Q
 ;
 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
 S:DDWC-1>$L(DDWN) DDWN=DDWN_$J("",DDWC-$L(DDWN)-1)
 S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)_DDWQ_$E(DDWN,DDWC+DDWREP,999)
 S DDWC=DDWC+1
 ;
 I DDWREP W DDWQ
 E  D
 . I $P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ
 . E  W DDWQ_$E(DDWN,DDWC,IOM+DDWOFS)
 D POS(DDWRW,DDWC,"R")
 D:$L(DDWN)>DDWRMAR WRAP^DDW5
 Q
 ;
RUB N DDWX
 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
 ;
 I DDWC=1 D
 . I DDWRW=1 D
 .. I 'DDWA W $C(7)
 .. E  D MVBCK^DDW3(1),POS(1,"E","R")
 . E  D POS(DDWRW-1,"E","RN")
 E  D
 . S DDWC=DDWC-1,$E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN
 . S DDWX=$E(DDWN,IOM+DDWOFS)
 . I DDWC-DDWOFS>0 D
 .. D CUP(DDWRW,DDWC-DDWOFS)
 .. I $P(DDGLED,DDGLDEL,6)]"" D
 ... W $P(DDGLED,DDGLDEL,6)
 ... I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
 .. E  W $E(DDWN_" ",DDWC,IOM+DDWOFS) D CUP(DDWRW,DDWC-DDWOFS)
 . E  D POS(DDWRW,DDWC)
 Q
 ;
DEL N DDWX
 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
 ;
 I DDWC>$L(DDWN) D  Q
 . I DDWN?." " D
 .. D XLINE^DDW5()
 . E  D
 .. N DDWY,DDWX
 .. S DDWY=DDWRW+DDWA,DDWX=DDWC
 .. D JOIN^DDW6
 .. D POS(DDWY-DDWA,DDWX,"RN")
 ;
 S $E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN,DDWX=$E(DDWN,IOM+DDWOFS)
 I $P(DDGLED,DDGLDEL,6)]"" D
 . W $P(DDGLED,DDGLDEL,6)
 . I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
 E  D
 . W $E(DDWN_" ",DDWC,IOM+DDWOFS)
 . D CUP(DDWRW,DDWC-DDWOFS)
 Q
 ;
STATUS N DDWX,DDWS
 S DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1)
 S DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT
 S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX
 S DDWX="Col "_DDWC
 S $E(DDWS,IOM-$L(DDWX),999)=DDWX
 D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_DDWS
 D POS(DDWRW,DDWC)
 Q
 ;
UP I DDWRW>1 D
 . D POS(DDWRW-1,DDWC,"RN")
 E  I DDWA D
 . D MVBCK^DDW3(1)
 E  W $C(7)
 I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
 Q
DN I DDWA+DDWRW'<DDWCNT W $C(7) Q
 I DDWRW<DDWMR D
 . D POS(DDWRW+1,DDWC,"RN")
 E  I DDWSTB D
 . D MVFWD^DDW3(1)
 E  W $C(7) Q
 I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
 Q
RT I DDWC>245,DDWC>$L(DDWN) W $C(7)
 E  D POS(DDWRW,DDWC+1,"R")
 Q
LT I DDWC=1 D
 . I DDWRW=1,'DDWA W $C(7)
 . E  D UP,POS(DDWRW,"E","R")
 E  D POS(DDWRW,DDWC-1,"R")
 Q
 ;
SV G SV^DDW1
SW D SAVE^DDW1 S DDWFIN="",DIWESW=1 Q
EX D SAVE^DDW1 S DDWFIN="" Q
QT S DDWFIN="" Q
TO D SAVE^DDW1 S DTOUT=1,DDWFIN="" W $C(7) Q
HLP D HLP^DDWH,POS(DDWRW,DDWC) Q
 ;
TST G TSET^DDW2
LST G LSET^DDW2
RST G RSET^DDW2
WRM G WRAPM^DDW2
RPM G REPLM^DDW2
ST G STAT^DDW2
 ;
TOP G TOP^DDW3
BOT G BOT^DDW3
 ;
PDN G PGDN^DDW4
PUP G PGUP^DDW4
TAB G TAB^DDW4
JLT G JLEFT^DDW4
JRT G JRIGHT^DDW4
LB G LBEG^DDW4
LE G LEND^DDW4
WRT G WORDR^DDW4
WLT G WORDL^DDW4
DLW G DELW^DDW4
DEOL G DEOL^DDW4
 ;
BRK D BREAK^DDW5() Q
XLN D XLINE^DDW5() D:DDWC'=1 POS(DDWRW,1,"R") Q
JN G JOIN^DDW6
RFT G REFMT^DDW6
 ;
MRK G MARK^DDW7
UMK G UNMARK^DDW7
 ;
CPY D COPY^DDW8() Q
CUT D CUT^DDW8() Q
PST D PASTE^DDW8() Q
 ;
FND G FIND^DDWF
NXT G NEXT^DDWF
GTO G GOTO^DDWG
CHG G CHG^DDWC
 ;
READ(DDWTO,Y) ;Out: Y=Char or mnem
 F  D  Q:Y'=-1
 . R *Y:DDWTO
 . I Y>127 D HS(.Y)
 . I Y>31,Y<127 S Y=$C(Y) Q
 . I Y<0 S Y="TO" Q
 . D MNE(.Y)
 Q
 ;
PREAD(DDWLEN,DDWTO,DDWST,Y) ;
 ;In:  DDWLEN=# chars to read
 ;Out:  DDWST=String
 ;          Y=Mnem, "" if DDWLEN chars read or invalid
 X DDGLZOSF("EON")
 R DDWST#DDWLEN:DDWTO E  S Y="TO" Q
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
 ;
 D:DDWST?.E1.C.E H(.DDWST)
 ;
 I $C(Y)?1C,Y D
 . D MNE(.Y)
 . I Y=-1 S Y=""
 . E  I $L(Y)=1 W Y S DDWST=DDWST_Y,Y=""
 E  S Y=""
 Q
 ;
MNE(Y) ;Out: Y=Mnem, -1 if invalid
 N S,F
 I Y=13 S DDWHLOG=$P($H,",",2)
 E  I Y=10,$D(DDWHLOG)#2,$P($H,",",2)-DDWHLOG<1 K DDWHLOG S Y=-1 Q
 E  K DDWHLOG
 S S="",F=0
 F  D MNELOOP Q:F
 Q
 ;
MNELOOP ;Read more
 S S=S_$C(Y)
 I DDW("IN")'[(U_S) D  I Y=-1 D FLUSH Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32)
 . S:DDW("IN")'[(U_S_U) Y=-1
 ;
 I DDW("IN")[(U_S_U),S'=$C(27) D  Q
 . S Y=$P(DDW("OUT"),U,$L($P(DDW("IN"),U_S_U),U)),F=1
 ;
 R *Y:5 D:Y=-1 FLUSH
 Q
 ;
H(DDWST) ;
 S DDWST=$TR(DDWST,$C(145,146,147,148),"''""""")
 I DDWST?.E1.C.E D
 . N DDWCON,DDWI
 . S DDWCON=""
 . F DDWI=128:1:255 S DDWCON=DDWCON_$C(DDWI)
 . S DDWST=$TR(DDWST,DDWCON,$J(" ",128))
 D POS(DDWRW,DDWC)
 W DDWST
 Q
 ;
HS(Y) ;
 I Y>144,Y<149 S Y=$A($E("''""""",Y-144))
 E  S Y=32
 Q
 ;
FLUSH ;
 N DDWX
 S F=1 W $C(7) F  R *DDWX:0 E  Q
 Q
 ;
CUP(Y,X) ;
 S DY=IOTM+Y-2,DX=X-1 X IOXY
 Q
 ;
POS(R,C,F) ;Pos cursor
 N DDWX
 S:$G(C)="E" C=$L($G(DDWL(R)))+1
 S:$G(F)["N" DDWN=$G(DDWL(R))
 S:$G(F)["R" DDWRW=R,DDWC=C
 ;
 S DDWX=C-DDWOFS
 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)

DDXP
DDXP ;SFISC/DPC-EXPORT MENU DRIVER ;12/17/92  10:13 ;10/30/92  10:01
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NOKL ;
 I ($G(^DIC(.44,0,"GL"))'="^DIST(.44,")!($G(^DIC(.81,0,"GL"))'="^DI(.81,") W !!,$C(7),"SORRY. You cannot use the Data Export options",!,"because you do not have the necessary files on your system." G Q^DII1
 S DIK="^DOPT(""DDXP"","
 I $D(^DOPT("DDXP",5)) G CHOOSE
 S ^DOPT("DDXP",0)="DATA EXPORT TO FOREIGN FORMAT OPTION^1.01^" K ^("B")
 F I=1:1:5 S ^DOPT("DDXP",I,0)=$P($T(@I),";;",2)
 K I D IXALL^DIK
CHOOSE ;
 W ! S DIC=DIK,DIC(0)="AEQI" D ^DIC K DIC,DIK
 I Y'<0 S X=+Y K Y D @X G NOKL
 W !
 G Q^DII1
 ;
1 ;;DEFINE FOREIGN FILE FORMAT
 S DDXP=1 D EN1^DDXP1
 D Q
 Q
 ;
2 ;;SELECT FIELDS FOR EXPORT
 S DDXP=2 D EN1^DDXP2
 D Q
 Q
 ;
3 ;;CREATE EXPORT TEMPLATE
 S DDXP=3 D EN1^DDXP3
 D Q
 Q
 ;
4 ;;EXPORT DATA
 S DDXP=4 D EN1^DDXP4
 D Q
 Q
 ;
5 ;;PRINT FORMAT DOCUMENTATION
 S DDXP=5 D EN1^DDXP5
 D Q
 Q
Q ;
 K DDXP,X,DIRUT,DUOUT,DTOUT Q

DDXP1
DDXP1 ;SFISC/DPC-CREATE/EDIT FOREIGN FORMAT ;1/8/93  09:09
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
 K DA S DLAYGO=0
GETFF ;
 W !
 S DIC="^DIST(.44,",DIC(0)="QEALMZ" D ^DIC K DIC
 G:Y=-1 QUIT
 S DDXPFMNM=$P(Y,U,2),DDXPFMNO=+Y
 I $P(Y(0),U,9) D USEDFF G:'($D(DA)#2) GETFF
EDITFF ;
 S:'($D(DA)#2) DA=DDXPFMNO S DDSFILE="^DIST(.44,",DR="[DDXP FF FORM1]"
 D ^DDS
QUIT ;
 K DDXPFMNM,DDXPFMNO,DA,DR,DDSFILE,Y,DLAYGO,X
 Q
USEDFF ;
 W !!,DDXPFMNM_" foreign format has been used to create an Export Template."
 W !,"Therefore, its definition cannot be changed.",!
 S DIR(0)="YA",DIR("A")="Do you want to see the contents of "_DDXPFMNM_" format? ",DIR("B")="NO"
 D ^DIR K DIR Q:$D(DIRUT)
 I Y W !! S DIC="^DIST(.44,",DA=DDXPFMNO D EN^DIQ K DIC,DA
 S DIR(0)="YA",DIR("A")="Do you want to use "_DDXPFMNM_" as the basis for a new format? ",DIR("B")="NO"
 D ^DIR K DIR Q:$D(DIRUT)!('Y)
NEWFF S DIC="^DIST(.44,",DIC(0)="QEAL",DIC("A")="Name for new FOREIGN FORMAT: " W !
 D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))!(X="")
 I '$P(Y,U,3) W !,$C(7),$P(Y,U,2)_" is already being used.",!,"Please enter a new name for the format.",! G NEWFF
 S DDXPFMNM=$P(Y,U,2),(DIT("F"),DIT("T"))="^DIST(.44,",DA("F")=DDXPFMNO,(DA("T"),DDXPFMNO)=+Y D EN^DIT0
 S DIE="^DIST(.44,",DA=DDXPFMNO,DR="40///0" D ^DIE K DIT,DIE,DR,Y
 Q
 ;
FORMVAL ;
 N FLDLM,FIXREC,MSGCNT,ERRMSG,USEQT,MAXLEN,SUBNULL S DDSERROR=0,MSGCNT=1
 S FLDLM=$$GET^DDSVAL(DIE,DA,1),FIXREC=$$GET^DDSVAL(DIE,DA,5),USEQT=$$GET^DDSVAL(DIE,DA,8),MAXLEN=$$GET^DDSVAL(DIE,DA,7),SUBNULL=$$GET^DDSVAL(DIE,DA,11)
 I FIXREC D
 . I FLDLM]"" D
 . . S DDSERROR=DDSERROR+1
 . . S ERRMSG(MSGCNT)="You cannot specify a record delimiter and",MSGCNT=MSGCNT+1
 . . S ERRMSG(MSGCNT)="indicate that record lengths are fixed",MSGCNT=MSGCNT+1
 . . S ERRMSG(MSGCNT)="for the same foreign format.",MSGCNT=MSGCNT+1
 . . Q
 . I USEQT D
 . . S DDSERROR=DDSERROR+1
 . . S ERRMSG(MSGCNT)="You cannot choose to have non-numeric fields quoted",MSGCNT=MSGCNT+1
 . . S ERRMSG(MSGCNT)="when you are exporting fixed length records.",MSGCNT=MSGCNT+1
 . . Q
 . I MAXLEN>255 D
 . . S DDSERROR=DDSERROR+1
 . . S ERRMSG(MSGCNT)="You cannot set the Maximum Record Length larger than 255 characters ",MSGCNT=MSGCNT+1
 . . S ERRMSG(MSGCNT)="when you are defining a fixed record length format.",MSGCNT=MSGCNT+1
 . . Q
 . I SUBNULL]"" D
 . . S DDSERROR=DDSERROR+1
 . . S ERRMSG(MSGCNT)="During fixed length exports, null values will always be exported as nothing.",MSGCNT=MSGCNT+1
 . . S ERRMSG(MSGCNT)="So, you cannot specify characters to be substituted for null numeric values.",MSGCNT=MSGCNT+1
 . . Q
 . Q
 I DDSERROR D
 . S ERRMSG(MSGCNT)=" ",MSGCNT=MSGCNT+1
 . S ERRMSG(MSGCNT)="Please correct "_$S(DDSERROR>1:"these discrepancies.",1:"this discrepancy."),MSGCNT=MSGCNT+1
 . S ERRMSG(MSGCNT)="You CANNOT save the form until you correct it!"
 . Q
 D:DDSERROR MSG^DDSUTL(.ERRMSG)
 K:'DDSERROR DDSERROR
 Q

DDXP2
DDXP2 ;SFISC/DPC-SELECTED FIELDS FOR EXPORT ;10/11/94  14:34
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
 N Y,D,DICS D ^DICRW I Y=-1 G QUIT
 S Q="""",C=",",DC=0,L=1,DI=DIC,DALL(1)=1 W !
 D ^DIP2
 I $D(DDXPFDTM) S DIE="^DIPT(",DA=DDXPFDTM,DR="8///7" D ^DIE
QUIT ;
 K C,DA,DALL,DC,DI,DIE,DIC,DR,DTOUT,DUOUT,L,Q
 Q
VALALL ;
 W !,$C(7),"SORRY.  When choosing export fields, you cannot use ALL to select all fields.",!
 S Y=0 K X
 Q
VAL1 ;validates raw user input -- X contains user input
 S DDXPNG=0
 F DDXPCK=";C",";D",";L",";N",";R",";S",";T",";W",";X" D
 . I X[DDXPCK S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot add "_DDXPCK_" to the export field specifications.",!
 . Q
 F DDXPCK="+","#","*","&","!" D
 . I $E(X)=DDXPCK S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot choose the "_DDXPCK_" statistical operator when selecting fields for export.",!
 . Q
 I $E(X,$L(X))=":" S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot jump to another file when selecting fields for export.",!
 I X[";""" S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot enter a custom heading when selecting fields for export."
 K:DDXPNG X K DDXPNG,DDXPCK
 Q
VAL2 ;validates found field -- Y(0) contains 0-node of field DD
 S DDXPNG=0
 S %=+$P(Y(0),U,2) I '% G VAL2OUT
 I $P($G(^DD(%,.01,0)),U,2)["W" S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot choose a word processing field for export.",!
VAL2OUT K:DDXPNG Y(0) K %,DDXPNG
 Q
VAL3 ;validates expression returned from DICOMP -- S contains expression
 S DDXPNG=0
 I S[";W"!(S[";m") S DDXPNG=1 W !!,$C(7),"SORRY.  That response is not acceptable when selecting fields for export.",!
 K:DDXPNG S K DDXPNG
 Q

DDXP3
DDXP3 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;10/14/94  14:56
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
 N DDXPNOUT
 N T,Q S T="~",Q="""" K ^TMP($J,"DIP")
 N Y,D,DICS D ^DICRW I Y=-1 G QUIT
 S DDXPFINO=+Y
FLDT ;
 D FLDTEMP^DDXP33 G:DDXPOUT QUIT
FRMT ;
 S DIC="^DIST(.44,",DIC(0)="QEAMZ" D ^DIC K DIC
 G:Y=-1 QUIT
 S DDXPFMNO=+Y,DDXPFMZO=Y(0)
XPTEMP ;
 D XPT^DDXP31 G:DDXPOUT QUIT
 D FLOAD,CAPDT^DDXP32 G:DDXPOUT QUIT
 I $P(DDXPFMZO,U,6) D LENGTH^DDXP31 G:DDXPOUT QUIT
 I $P(DDXPFMZO,U,7) D FLDNAME^DDXP31 G:DDXPOUT QUIT
 I $P(DDXPFMZO,U,11) D DTYPE^DDXP31 G:DDXPOUT QUIT
 D SETFLD^DDXP32
 I '$P(DDXPFMZO,U,8) D IOM^DDXP31 G:DDXPOUT QUIT S ^DIPT(DDXPXTNO,"IOM")=$G(DDXPIOM)
 D SETEMP^DDXP32
SETDELM ;
 I $TR($P(DDXPFMZO,U,2),"ask","ASK")="ASK" D ASKDELM^DDXP31 G:DDXPOUT QUIT
 S:'$D(DDXPDELM) DDXPDELM=$P(DDXPFMZO,U,2)
 I DDXPDELM]"" S DDXPDELM=$$BLDELIM(DDXPDELM)
TPROC ;
 S DDXPFONO=1,DDXPFOUT="",DDXPXPOS=1
 F DDXPFLD=1:1:DDXPTOTF D
 . S (DDXPNPC,DDXPRNPC)=^TMP($J,"TIN",DDXPFLD)
 . I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32
 . I $P(DDXPFMZO,U,6) D FIXLEN
 . I '$P(DDXPFMZO,U,6),((DDXPFLD'=1)!(DDXPNPC'=DDXPRNPC)) D RUNON
 . I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32
 . I DDXPDELM]"",'DDXPNOUT(DDXPFLD) D DELIM
 . D FPROC
 . Q
RECPROC ;
 I '$P(DDXPFMZO,U,12),DDXPDELM]"" S DDXPFOUT=$P(DDXPFOUT,T,1,($L(DDXPFOUT,T)-2))_T
 I $TR($P(DDXPFMZO,U,3),"ask","ASK")="ASK" D ASKRDLM^DDXP31 G:DDXPOUT QUIT
 S:'$D(DDXPRDLM) DDXPRDLM=$P(DDXPFMZO,U,3)
 I DDXPRDLM]"" S DDXPRDLM=$$BLDELIM(DDXPRDLM) D RECDELIM D FPROC
FINISH ;
 I DDXPFOUT]"" S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
 S DIE="^DIST(.44,",DA=DDXPFMNO,DR="40///1" D ^DIE
 S DIE="^DIPT(",DA=DDXPFDTM,DR="110///1" D ^DIE K DIE,DA,DR
 W !!,?10,"Export Template created.",!
 I $G(DDXPTMDL) D
 . S DIK="^DIPT(",DA=DDXPFDTM D ^DIK K DIK,DA
 . W ?10,"Selected Fields template "_DDXPFDNM_" deleted.",!
 . Q
 G DONE
QUIT ;
 W !!,?10,"Export Template NOT created!!"
 I $G(DDXPTMDL) W !,?10,"Selected Fields template "_DDXPFDNM_" not deleted."
 I $D(DDXPXTNO) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
DONE ; 
 K X,Y,DDXPDELM,DDXPDT,DDXPFDTM,DDXPFCAP,DDXPFFNM,DDXPFIN,DDXPFINO,DDXPFLD,DDXPIOM,DDXPFLEN,DDXPFMNO,DDXPFMZO,DDXPFONO,DDXPTLEN,DDXPTMDL
 K DDXPFDNM,DDXPFOUT,DDXPLNMX,DDXPRNPC,DDXPNPC,DDXPOUT,DDXPTIN,DDXPATH,DDXPTOTF,DDXPXPOS,DDXPXTNM,DDXPXTNO,DDXPRDLM,Q,T,DTOUT,DUOUT,DIRUT
 K ^TMP($J,"DIP")
 Q
FLOAD ;
 S DDXPFLD=0
 F FIN=0:0 S FIN=$O(^DIPT(DDXPFDTM,"F",FIN)) Q:FIN=""  S DDXPFIN=^(FIN) D
 . F TCNT=1:1 S DDXPTIN=$P(DDXPFIN,T,TCNT) Q:DDXPTIN=""  D
 . . S DDXPFLD=DDXPFLD+1
 . . S ^TMP($J,"TIN",DDXPFLD)=DDXPTIN
 . . S DDXPNOUT(DDXPFLD)=$$NOUT(DDXPTIN)
 . . Q
 . Q
 S DDXPTOTF=DDXPFLD
 K FIN,TCNT Q
FIXLEN ;
 S DDXPLNMX=$S(+$P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(DDXPIOM):DDXPIOM,1:80)
 I DDXPXPOS+DDXPFLEN(DDXPFLD)>(DDXPLNMX+1) S DDXPXPOS=1
 S DDXPNPC=DDXPNPC_";L"_DDXPFLEN(DDXPFLD)_";C"_DDXPXPOS
 S DDXPXPOS=DDXPXPOS+DDXPFLEN(DDXPFLD)
 Q
RUNON ;
 S DDXPNPC=DDXPNPC_";X"
 Q
DELIM ;
 S DDXPNPC=DDXPNPC_T_"W $C("_DDXPDELM_")"
 I '$P(DDXPFMZO,U,6) D RUNON
 Q
RECDELIM ;
 S DDXPNPC="W $C("_DDXPRDLM_")"
 I '$P(DDXPFMZO,U,6) D RUNON
 Q
BLDELIM(%) ;
 N CHAR,DELM
 I +% S DELM=% G BLDOUT
 S DELM=$A(%)
 F CHAR=2:1 Q:$E(%,CHAR)=""  S DELM=DELM_","_$A($E(%,CHAR))
BLDOUT Q DELM
FPROC ;
 I $L(DDXPFOUT)+$L(DDXPNPC)<220 S DDXPFOUT=DDXPFOUT_DDXPNPC_T Q
 S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
 S DDXPFOUT=DDXPNPC_T,DDXPFONO=DDXPFONO+1
 Q
 ;
NOUT(DDXPTIN) ;
 I DDXPTIN["SETDATA"!(DDXPTIN["SETPARAM") Q 1
 Q 0

DDXP31
DDXP31 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;10/14/94  14:56
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
XPT ;
 S DDXPOUT=0
 S DIR(0)="F^2:30",DIR("A")="Enter name for EXPORT Template"
 S DIR("?",1)="Enter the name of the Export Template to be produced.",DIR("?",2)="The name must be from 2 to 30 characters.",DIR("?")="The new Export Template cannot overwrite an existing Print Template file entry."
 D ^DIR K DIR
 I $D(DIRUT) S DDXPOUT=1 Q
 S DIC="^DIPT(",DIC(0)="XL",DLAYGO=0 W ! D ^DIC K DIC,DLAYGO
 I '$P(Y,U,3) W !,$C(7),$P(Y,U,2)_" entry in the Print Template file already exists.",!,"Please enter the name of a new template.",!! G XPT
 S DDXPXTNO=+Y
 Q
LENGTH ;
 W !!,"This template will produce fixed length records."
 W !,"Enter the length of each field below."
 W !,"The specified number should be the length in the TARGET file.",!!
 D GETOUT Q:DDXPOUT
 S DDXPTLEN=0
 S DIR(0)="N^1:255:0",DIR("?")="Enter a number from 1 to 255 as the length of this field in the TARGET file"
 F DDXPFLD=1:1:DDXPTOTF D  I DDXPOUT Q  G LENGTH
 . I DDXPNOUT(DDXPFLD) S DDXPFLEN(DDXPFLD)=0 Q
 . S DIR("A")=DDXPFCAP(DDXPFLD),DDXPOUT=0 D ^DIR
 . I $D(DIRUT) S DDXPOUT=1 Q
 . S DDXPFLEN(DDXPFLD)=Y,DDXPTLEN=DDXPTLEN+Y
 . Q
 K DIR,X,Y
 Q
FLDNAME ;
 W !!,"Enter the name of the fields below in the TARGET file."
 W !,"If you press <RET>, no name will be used.",!!
 D GETOUT Q:DDXPOUT
 S DIR(0)="FO^0:30"
 S DIR("?")="Enter up to 30 characters as the name of this field in the TARGET file"
 F DDXPFLD=1:1:DDXPTOTF D  I DDXPOUT=1 Q  G FLDNAME
 . I DDXPNOUT(DDXPFLD) Q
 . S DIR("A")=DDXPFCAP(DDXPFLD),DDXPOUT=0 D ^DIR
 . I $D(DTOUT)!$D(DUOUT) S DDXPOUT=1 Q
 . S DDXPFFNM(DDXPFLD)=Y
 . Q
 K DIR,X,Y
 Q
DTYPE ;
 W !!,"Enter the data types of the fields being exported below.",!!
 D GETOUT Q:DDXPOUT
 S DIR(0)=".42,1"
 F DDXPFLD=1:1:DDXPTOTF D  I DDXPOUT=1 Q  G DTYPE
 . I DDXPNOUT(DDXPFLD) Q
 . S DIR("A")=DDXPFCAP(DDXPFLD),DIR("B")=$P(^DI(.81,DDXPDT(DDXPFLD),0),U,1),DDXPOUT=0 D ^DIR
 . I $D(DIRUT) S DDXPOUT=1 Q
 . S DDXPDT(DDXPFLD)=+Y
 . Q
 K DIR,X,Y
 Q
IOM ;
 S DDXPOUT=0
 W !!,"Enter the maximum length of a physical record that can be exported.",!,"Enter '^' to stop the creation of an EXPORT template.",!
 I $D(DDXPTLEN) D
 . W "The default shown is based on the total lengths of the fields being exported.",!
 . S DIR("B")=DDXPTLEN+1
 . Q
RIOM S DIR(0)=".44,7" D ^DIR K DIR
 I $D(DTOUT)!$D(DUOUT) S DDXPOUT=1 Q
 I Y>255,$P(DDXPFMZO,U,6) W !!,$C(7),"The length cannot be greater than 255 when sending fixed length records.",! G RIOM
 S DDXPIOM=Y
 Q
ASKDELM ;
 S DDXPOUT=0
 W !!,"You can choose a delimiter to be placed between output fields.",!,"Enter <RET> to use no delimiter.",!,"Enter '^' to stop the creation of an EXPORT template.",!
 S DIR(0)=".44,1" D ^DIR K DIR
 I $D(DUOUT)!$D(DTOUT) S DDXPOUT=1 Q
 S:X="@" Y=X S DDXPDELM=Y
 Q
ASKRDLM ;
 S DDXPOUT=0
 W !!,"You can choose a delimiter to be placed between output records.",!,"Enter <RET> to use no delimiter",!,"Enter '^' to stop the creation of an EXPORT template.",!
 S DIR(0)=".44,2" D ^DIR K DIR
 I $D(DUOUT)!$D(DTOUT) S DDXPOUT=1 Q
 S:X="@" Y=X S DDXPRDLM=Y
 Q
GETOUT ;To see if user wants to continue.
 S DDXPOUT=0
 W "Do you want to continue?"
 S DIR(0)="Y",DIR("B")="YES"
 S DIR("?")="If you do not give this information, an EXPORT template will NOT be created."
 D ^DIR K DIR I $D(DIRUT)!'Y S DDXPOUT=1 Q
 W !!
 Q

DDXP32
DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;10/14/94  14:57
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CAPDT ;
 K DDXPFCAP,DDXPDT,DDXPATH N FCAP,NUMPC,C S C=","
 F DDXPCNDX=1:1:DDXPTOTF D
 . I DDXPNOUT(DDXPCNDX) Q
 . S DDXPX=^TMP($J,"TIN",DDXPCNDX),DDXPTGFL=DDXPFINO,NUMPC=0 K FCAP
 . D FLDFIND
 . S DDXPFCAP(DDXPCNDX)=FCAP(NUMPC)
 . F NUMPC=NUMPC-1:-1 Q:'$D(FCAP(NUMPC))  D
 . . S DDXPFCAP(DDXPCNDX)=DDXPFCAP(DDXPCNDX)_" in "_FCAP(NUMPC)_" subfile"
 . . Q
 . K FCAP,NUMPC
 . Q
 I $D(DDXPATH) D MULTVER
 K DDXPX,DDXPCNDX,DDXPTGFL,DDXPDD0 Q
FLDFIND ;
 S NUMPC=NUMPC+1
 I DDXPX=0 D  Q
 . S FCAP(NUMPC)="NUMBER",DDXPDT(DDXPCNDX)=4
 . Q
 I +DDXPX D
 . S DDXPDD0="^DD("_DDXPTGFL_","_+DDXPX_",0)"
 . Q
 I DDXPX=+DDXPX D  Q
 . S FCAP(NUMPC)=$P(@DDXPDD0,U,1)
 . S %=$P(@DDXPDD0,U,2),DDXPDT(DDXPCNDX)=$S(%["D":1,%["N":2,1:4) K %
 . Q
 I '+DDXPX D  Q
 . S DDXPDT(DDXPCNDX)=4
 . I $E(DDXPX)=Q S FCAP(NUMPC)=DDXPX Q
 . S %=$P(DDXPX,";Z;",2),%=$P(%,Q,2,99),%=$P(%,";",1),FCAP(NUMPC)=$E(%,1,($L(%)-1)) K %
 . Q
MULT ;
 S FCAP(NUMPC)=$P(@DDXPDD0,U,1)
 S DDXPTGFL=+$P(@DDXPDD0,U,2)
 I NUMPC=1 D
 . N %,I,DONE S %=$P(DDXPX,C,1,$L(DDXPX,C)-1),DONE=0
 . F I=2:1:$L(DDXPX,C) Q:DONE  D
 . . Q:+$P(%,C,I)
 . . S %=$P(%,C,1,I-1),DONE=1
 . . Q
 . S DDXPATH(DDXPCNDX)=%
 . Q
 S DDXPX=$P(DDXPX,C,2,99)
 G FLDFIND
SETFLD ;
 S %L=$S($D(DDXPFLEN):";2///^S X=DDXPFLEN(DDXPFLD)",1:"")
 S %F=$S($D(DDXPFFNM):";3///^S X=DDXPFFNM(DDXPFLD)",1:"")
 S (DIC,DIE)="^DIPT("_DDXPXTNO_",100,",DA(1)=DDXPXTNO,DIC("P")=$P(^DD(.4,100,0),U,2),DIC(0)="L" K DO
 F DDXPFLD=1:1:DDXPTOTF D
 . I DDXPNOUT(DDXPFLD) Q
 . S (DINUM,X)=DDXPFLD K DD D FILE^DICN
 . S DA=DDXPFLD,DR="1////^S X=DDXPDT(DDXPFLD)"_%L_%F D ^DIE
 . Q
 K DIE,DIC,X,Y,DA,DR,%L,%F
 Q
SETEMP ;
 S DR="2///NOW;3///"_DUZ(0)_";4///"_DDXPFINO_";5///"_DUZ_";6///"_DUZ(0)_";8///3;105////"_DDXPFMNO S:$G(DDXPATH) DR=DR_";115///"_DDXPATH
 S DA=DDXPXTNO,DIE="^DIPT(" D ^DIE K DIE,DA,DR
 S %X="^DIPT("_DDXPFDTM_",""DXS"",",%Y="^DIPT("_DDXPXTNO_",""DXS""," D %XY^%RCR K %X,%Y
 S ^DIPT(DDXPXTNO,"SUB")=1
 S ^DIPT(DDXPXTNO,"H")="@@"
 Q
MULTVER ;
 N I,MP,LP,MPC,LPC,NOMATCH S LP="",NOMATCH=0
 F I=1:1:DDXPTOTF D  Q:NOMATCH
 . S MP=$G(DDXPATH(I)) Q:'MP
 . I LP=MP Q
 . I 'LP S LP=MP Q
 . S LPC=$L(LP,C),MPC=$L(MP,C)
 . I LPC=MPC S NOMATCH=1 Q
 . I LPC>MPC D  Q
 . . I MP=$P(LP,C,1,MPC) Q
 . . S NOMATCH=1
 . . Q
 . I LP=$P(MP,C,1,LPC) S LP=MP Q
 . S NOMATCH=1
 . Q
 I 'NOMATCH S DDXPATH=LP Q
 W !!,$C(7),"The "_DDXPFDNM_" template has fields in more than one multiple path."
 W !,"Therefore, export of the data will not succeed."
 W !,"Refer to the VA FileMan User Manual for more details.",!
 S DDXPOUT=1
 Q
QUOT ;
 N QPC,Q1ST
 I DDXPDT(DDXPFLD)=2 Q
 S Q1ST=$S(DDXPNPC=DDXPRNPC:1,1:0)
 S QPC="W $C(34)"_$S(Q1ST&(DDXPFLD=1):"",1:";X")
 I Q1ST S DDXPNPC=QPC_T_DDXPNPC
 E  S DDXPNPC=DDXPNPC_T_QPC
 Q

DDXP33
DDXP33 ;SFISC/DPC - CREATE EXPORT TEMPLATE (CONT);1/8/93  09:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FLDTEMP ;
 S DDXPOUT=0
 S DIC="^DIPT(",DIC(0)="QEAS",DIC("S")="I $P(^(0),U,8)=7",DIC("A")="Enter SELECTED EXPORT FIELDS Template: ",D="F"_DDXPFINO W ! D IX^DIC K DIC,D
 I Y=-1 S DDXPOUT=1 Q
 S DDXPFDTM=+Y,DDXPFDNM=$P(Y,U,2)
 D SHOWFLD G:DDXPOUT FLDTEMP
 Q
SHOWFLD ;
 W !!,"Do you want to see the fields stored in the "_DDXPFDNM_" template?"
 S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR
 I $D(DIRUT) S DDXPOUT=1 Q
 I Y D  Q:DDXPOUT
 . W ! S D0=DDXPFDTM D ^DIPT K D0
 . W !,"Do you want to use this template?"
 . S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR W !
 . I 'Y!$D(DIRUT) S DDXPOUT=1
 . Q
 S DDXPTMDL=0
 W !!,"Do you want to delete the "_DDXPFDNM_" template"
 W !,"after the export template is created?"
 S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
 I $D(DIRUT) S DDXPOUT=1 Q
 S:Y DDXPTMDL=1
 Q

DDXP4
DDXP4 ;SFISC/DPC-EXPORT DATA ;10/17/94  14:27
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
 K ^UTILITY($J)
 D ^DICRW I Y=-1 G QUIT
 S DDXPFINO=+Y
XTEM ;
 S DIC="^DIPT(",DIC(0)="QEASZ",DIC("A")="Choose an EXPORT template: ",DIC("S")="I $P(^(0),U,8)=3",D="F"_DDXPFINO W !
 D IX^DIC K DIC,D I $D(DTOUT)!$D(DUOUT) G QUIT
 I Y=-1 G XTEM
 S DDXPXTNO=+Y,DDXPXTNM=$P(Y,U,2),FLDS="["_DDXPXTNM_"]"
 W !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
 S DDXPTMDL=0,DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
 I $D(DIRUT) G QUIT
 S:Y DDXPTMDL=1
 S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
 I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
 S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
SORS ;
 W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to SEARCH for entries to be exported? "
 S DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
 S:'$D(BY) DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
 S DIR("?")="If you answer 'NO', "_$S('$D(BY):"you can only SORT entries before export.",1:"the data export will begin.")
 D ^DIR K DIR I $D(DIRUT) G QUIT
 S DDXPSORS=Y,DIC=DDXPFINO,L=0
 D DIOBEG,DIOEND
 I DDXPSORS D EN^DIS
 I 'DDXPSORS D EN1^DIP
 I $G(X)="^"!($G(POP)) G QUIT
 I $G(DDXPQ) W !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed." G DONE
 I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
 G DONE
QUIT ;
 W !!,?10,"Export NOT completed!"
DONE ;
 K DDXPFINO,DDXPSORS,DDXPIOM,DDXPIOSL,DDXPXTNO,DDXPXTNM,DDXPFFNO,DDXPFMZO,DDXPCUSR,DDXPDATE,DDXPTMDL,DDXPY,DDXPATH,L,Y,DTOUT,DUOUT,DIRUT,DIC,FLDS,BY,FR,DIOEND,DIOBEG,DDXPQ,X,POP
 Q
ZIS ;
 S %ZIS="Q"
 S DDXPIOM=$S($P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
 S DDXPIOSL=99999
 Q
MULTBY ;
 N NUMPC,I,C S BY="",C=",",NUMPC=$L(DDXPATH,C)
 W !!,"Since you are exporting fields from multiples,"
 W !,"a sort will be done automatically."
 W !,"You will not have the opportunity to sort the data before export.",!
 F I=1:1:NUMPC D
 . S BY=BY_DDXPATH_",NUMBER,"
 . S DDXPATH=$P(DDXPATH,C,1,$L(DDXPATH,C)-1)
 . Q
 S BY=$E(BY,1,$L(BY)-1),FR=""
 Q
DIOBEG ;
 S DDXPBEG=$G(^DIST(.44,DDXPFFNO,1))
 I DDXPBEG']"" G QBEG
 I $E(DDXPBEG)="""" S DIOBEG="W "_DDXPBEG G QBEG
 S DIOBEG=DDXPBEG
QBEG K DDXPBEG
 Q
DIOEND ;
 S DDXPEND=$G(^DIST(.44,DDXPFFNO,2))
 I DDXPEND']"" G QEND
 I $E(DDXPEND)="""" S DIOEND="W "_DDXPEND G QEND
 S DIOEND=DDXPEND
QEND K DDXPEND
 Q
DJTOPY(Y) ;
 N BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB S YOUT=Y
 S BJ=$F(Y,"$J(") I BJ D
 . S DDXPXORY=$P($E(Y,BJ,999),",",1)
 . S NUMW=$L($E(Y,1,BJ),"W")-1 I NUMW'>0 Q
 . S EJ=$F(Y,") ",BJ)
 . S TYPEJ=$L($E(Y,BJ,$S(EJ:EJ-1,1:999)),",")
 . I TYPEJ'=2&(TYPEJ'=3) Q
 . I TYPEJ=3 S SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$P(DDXPFMZO,U,13)_""")"
 . I TYPEJ=2 S SUB=DDXPXORY
 . S YOUT=$P($E(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$S(EJ:$E(Y,EJ-1,999),1:"")
 . Q
 Q YOUT
DT ;
 N X
 I 'Y S DDXPY=Y Q
 S X=Y
 I $D(^DIST(.44,DDXPFFNO,6)) X ^(6) S DDXPY=$G(Y)
 Q

DDXP41
DDXP41 ;SFISC/DPC-EXPORT DATA (CONT);1/8/93  09:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SORTVAL ;
 N DDXPNG,CHK
 S DDXPNG=0
 F CHK="#","!","+","@" D
 . I $E(X)=CHK S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot use the "_CHK_" sort qualifier when exporting data.",!
 . Q
 F CHK=";C",";S" D
 . I X[CHK S DDXPNG=1 W !!,$C(7),"SORRY.  Using "_CHK_" will have no effect when exporting data.",!
 . Q
 I X[";""" S DDXPNG=1 W !!,$C(7),"SORRY.  You cannot replace a caption with a literal when exporting data.",!
 K:DDXPNG X
 Q

DDXP5
DDXP5 ;SFISC/DPC-PRINT FOREIGN FORMAT DOC ;12/17/92  10:15
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
 N SEL,CHOICE,OUT,NOMORE K DIS
 S DIR(0)="SM^1:Only print selected foreign formats;2:Print all foreign formats"
 D ^DIR K DIR Q:$D(DIRUT)  S SEL=Y,OUT=0
 I SEL=1 D  Q:$G(CHOICE)=1
 . S DIC="^DIST(.44,",DIC(0)="QEAM",NOMORE=0
 . F CHOICE=1:1 D  Q:OUT
 . . W ! D ^DIC I Y=-1 S OUT=1 Q
 . . S DIS(CHOICE)="I D0="_+Y
 . . Q
 . K DIC
 . Q
 S DIC="^DIST(.44,",L=0,FLDS="[DDXP FORMAT DOC]",DHD="[DDXP FORMAT DOC HDR]",BY="NAME;S2;C1",FR="" W !
 D EN1^DIP
 K Y,DIRUT
 Q

DDXPLIB
DDXPLIB ;SFISC/DPC-EXPORT LIBRARY ;1/25/93  13:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FLDNM(DDXPXTNO) ;
 N %D,%I,FLD,NAMELST,NAME
 S NAMELST=""
 S %D=$P($G(^DIST(.44,+$G(^DIPT(DDXPXTNO,105)),0)),U,2)
 S %D=$$BLDELIM^DDXP3(%D)
 S %D=$C(%D),FLD=0
 F %I=0:1 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1  D
 . S NAME=$P(^DIPT(DDXPXTNO,100,FLD,0),U,4)
 . S NAMELST=NAMELST_NAME_%D
 . Q
 S NAMELST=$P(NAMELST,%D,1,%I)
 Q NAMELST
 ;
DP123(DDXPXTNO) ;
 N FLD,FLDZO,DPLN,I,DT,LEN,DTCHAR
 S DPLN=""
 F FLD=0:0 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1  S FLDZO=^(FLD,0) D
 . S DT=$P(FLDZO,U,2)
 . S LEN=$P(FLDZO,U,3)
 . S DTCHAR=$S(DT=4:"L",DT=2:"V",DT=1:"D",1:"L")
 . S DPLN=DPLN_DTCHAR
 . F I=1:1:LEN-1 S DPLN=DPLN_">"
 . Q
 Q DPLN
 ;
DPXCEL(DDXPXTNO) ;
 N DPLN,FLD,FLDZO,LEN,I
 S DPLN=""
 F FLD=0:0 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1  S FLDZO=^(FLD,0) D
 . S LEN=$P(FLDZO,U,3)
 . S DPLN=DPLN_"|"
 . F I=1:1:LEN-1 S DPLN=DPLN_" "
 . Q
 Q DPLN
 ;
SASCOL ;
 N INPUTLN,FLD,NAME,DTYPE,DTYPEFOR,START,END,LENGTH,FLD0
 S INPUTLN="INPUT ",START=1,FLD=0
 F  S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1  S FLD0=^(FLD,0) D
 . S NAME=$P(FLD0,U,4)_" ",LENGTH=$P(FLD0,U,3),DTYPE=$P(FLD0,U,2)
 . S DTYPEFOR=$S(DTYPE=4:"$ ",DTYPE=1:"YYMMDD"_LENGTH_". ",1:"")
 . S END=START+LENGTH-1
 . S INPUTLN=INPUTLN_NAME_DTYPEFOR_$S(DTYPE=1:"",1:START_"-"_END_" ")
 . S START=END+1
 . Q
 S INPUTLN=$E(INPUTLN,1,$L(INPUTLN)-1)_";"
 W INPUTLN,!,"CARDS;"
 Q
 ;
ORACTL ;
 N FLD,FLD0,DELIM,NAME,LENGTH,DTYPEFRM,END,START,POS
 S FLD=0,DELIM=$P(^DIST(.44,DDXPFFNO,0),U,2),START=1,POS=""
 W "LOAD DATA",!
 W "INFILE *",!
 W "APPEND",!
 W "INTO TABLE "_$TR($P(^DIPT(DDXPXTNO,0),U,1)," ","_"),!
 W:DELIM]"" "FIELDS TERMINATED BY '"_DELIM_"' OPTIONALLY ENCLOSED BY '""'",!
 W "("
 F  S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1  W:FLD>1 ",",! S FLD0=^(FLD,0) D
 . S NAME=$P(FLD0,U,4)_" ",LENGTH=$P(FLD0,U,3)
 . S DTYPEFRM=$S($P(FLD0,U,2)=1:" DATE 'MON DD,YYYY'",1:"")
 . I LENGTH>0 D
 . . S END=START+LENGTH-1
 . . S POS="POSITION ("_START_":"_END_")"
 . . S START=END+1
 . . Q
 . W NAME_POS_DTYPEFRM
 W " )",!
 W "BEGINDATA",!
 Q

DI
DI ;SFISC/GFT-DIRECT ENTRY TO VA FILEMAN ;7/25/94  3:07 PM
V ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G QQ:$G(^DI(.84,0))']""
C G QQ:$G(^DI(.84,0))']"" K (DTIME,DUZ) G ^DII
D G QQ:$G(^DI(.84,0))']"" G ^DII
P G QQ:$G(^DI(.84,0))']"" K (DTIME,DUZ)
Q G QQ:$G(^DI(.84,0))']"" S DUZ(0)="@" G ^DII
VERSION ;
 S VERSION=$P($T(V),";",3),X="VA FileMan V."_VERSION Q
 ;
QQ ;
 W $C(7),!!,"You must run ^DINIT first."
 Q

DIA
DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;2/16/93  15:21 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D DICS
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
ED G NDB:DIAT=""
GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB
 I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2)
 I $D(DI(DB)),$D(DI(DB,F,DI,DIAO)) S Y=DI(DB,F,DI,DIAO)
 W ": "_Y D RW
 I X="" S X=Y I X="ALL" G ALL^DIA1
L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q
 I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2
 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
DIC ;
 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)
 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
 I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2
 S DIC(0)="EY",D="GR" G DIA^DIQQQ:X?."?" I $D(^DD(DI,D)) D IX^DIC I Y>0 D SET G 2
 G X^DIA3
 ;
F S X=$P(^DD(DI,0),U,1) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X
 Q
 ;
X ;
 W $C(7),"??" D DICS
2 ;
 G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB
R R ": ",X:DTIME E  W $C(7) S X=U,DTOUT=1
 I X]"" G L
UP ;
 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))
 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:"")
 S DIAP=DIAP(F),DI=J(L),F=F-1 G 2
 ;
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
 S DIAO=-1 G R
 ;
EN ;
 D OS^DII:'$D(DISYS),DICS
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:"")
 G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP
DICS ;
 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
 ;
P ;
 S DRS=99,Y=X D DB G 2
 ;
SET S Y=+Y_DV
DB ;
 I DB,'DSC S DB=DB+1
D ;
 I '$D(DR(F+1,DI)) S DR(F+1,DI)="",DIAP=0
 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
 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
 Q
RW I $L(Y)>19 D RW^DIR2 Q
 W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7)

DIA1
DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;2/16/93  15:21 ;2/22/93  3:29 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 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
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
 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
 S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2)
 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)
 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)
 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
Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q
 ;
ALL ;
 S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D A G UP^DIA:F,S:$D(DRS) Q
 ;
RANGE ;
 S %=DI I X>0 S Y=X-.000001 G B
A S Y=0
B S DA="",X=0
G S DG=Y
DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q
 I Y'>0 D DG:X S:$D(DR(F+1,%))[0 DR(F+1,%)=DA Q
 I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR
 X DIC("S") E  G DR
 S X=Y G G
 ;
DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG)
 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)=""
 S DQ=-1
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
 S X="",DG=0 K DP Q
 ;
TEMP ;
 S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT)  G DB:Y<0
 S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED
GT I $D(^("ROU")),^("ROU")[U S DR(1,DIA("P"))=^("ROU")
 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
 S $P(^DIE(+Y,0),U,7)=DT
 Q
 ;
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
 ;
ED I Y<1 G GT
 S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1
 S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB
 S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR")
 S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"")
 I $D(^DIE(DA,"DIAB")) S %X="^DIE(DA,""DIAB"",",%Y="DI(" D %XY^%RCR
 S F=0,DB=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS))
DB S DI=J(0) G ^DIA
 ;
OV I '$D(DW(X,I)) S DR(F,X,I)=J Q
 S DR(F,X,I)=DW(X,I),I=I+1 G OV

DIA2
DIA2 ;SFISC/GFT-SELECT ENTRY TO EDIT, ^LOOP ;9/7/94  09:28 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY("DIT",$J),DA,DRS,DW,DIAP,DI I '$D(DR(1,J(0))) S DR(1,J(0))=".01:99999999"
 I $L(DR(1,J(0)))+$L(DIA)<216,+DR(1,J(0))=.01 S DR(1,J(0))="S:DIA(9) DQ=2,X=$P("_DIA_"DA,0),U,1);"_DR(1,J(0))
DIC W !! G Q^DIB:$D(DTOUT) D L S DIA(1)=+Y,DIA(9)=$P(Y,U,3) I Y>0 D DIE,^DIA3:'$D(DA) G DIC
 I X'["LOOP",X'["loop" D PTS^DITP:$O(^UTILITY("DIT",$J,0))>0 K ^UTILITY("DIT",$J) G Q^DIB
 S L="EDIT ENTRIES",DHD="@",IOP="HOME",FLDS="",DHIT="D LOOP^DIA2 S:'$D(DCC) DN=0" D EN1^DIP W !!?4,"LOOP ENDED!" Q:$D(DTOUT)  G DIC
 ;
L K Y,I,J,F,DIC S (DIC,DIE)=DIA,DIC(0)="QEALM" G ^DIC
 ;
DIE S DP=DIA("P"),DA=+Y,DR=DR(1,DP)
 K DIC,Y,C,DB S DIC=DIE,DILK=DIE_DA_")" L @("+"_DILK_":0")
 E  W $C(7),!,"ANOTHER TERMINAL IS EDITING THIS ENTRY!" K DILK Q
 I DR?1"^".AN D @DR L @("-"_DILK) K DILK Q
 E  D GO^DIE L @("-"_DILK) K DILK Q
 ;
LOOP ;DELETE OR REPLACE POINTERS
 G NUL:$D(@(DCC_D0_",-9)")) I '($G(DIFIXPT)=1) W !!,?3
 S X=$P(@(DCC_"0)"),U,2) G NUL:'$D(^(D0,0)) S (DI,Y)=$P(^(0),U,1),C=$P(^DD(+X,.01,0),U,2) D Y^DIQ
 I $G(DIFIXPT)=1 D
 . I $D(DIFIXPTH) S ^TMP("DIFIXPT",$J,DIFIXPTC)=DIFIXPTH,DIFIXPTC=DIFIXPTC+1 K DIFIXPTH
 . S ^TMP("DIFIXPT",$J,DIFIXPTC)=" Entry:"_D0_"-"_$E(Y,1,20)_"     "
 . Q
 I '($G(DIFIXPT)=1) W Y
 S Y=D0,(DIE,DIC)=DCC,%C=0 I X["I",'($G(DIFIXPT)=1) S %Y=0 F  S %C=$O(^DD(+X,0,"ID",%C)) Q:%C=""  S %=^(%C) W "  ",$E(@(DCC_"Y,0)"),0) X %
 K DO S %C=-1,DO(2)=X,Y=Y_U_DI,DIC(0)=$P("E^",U,('($G(DIFIXPT)=1))) D ACT^DICM1 S DI=99 K DO,DIY Q:Y<0
 S Y=D0 D DIE S:$G(DIFIXPT) DIFIXPTC=DIFIXPTC+1 I $D(DTOUT) K DCC,Y
 I $D(Y) K Y I '($G(DIFIXPT)=1) S %=1 W $C(7),!!,"WANT TO STOP LOOPING" D YN^DICN I %-2 K DCC
NUL S DI=99,(^UTILITY($J,99,0),DX(0))="Q" K D1,D2,D3,D4,D5
 Q

DIA3
DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94  09:57 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 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
 D ASK^DITP Q:%-1
 S Y=0 I @("$O("_DIC_"0))'>0") G D
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
D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP
W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0
F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q
DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999)
 W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)"
 Q
 ;
FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS
 ;In V21, will just delete pointers.  Later, DIPTIEN will be record to repoint to.
 ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future)
 N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D  I $G(X)]"" D BLD^DIALOG(201,X) Q
 . 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"))=""
 . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y=""  I '$D(@(Y_DIPTIEN_",0)")) Q
 . K X Q
 S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1
 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)
 S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN
 D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT
 S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999)
 D P^DITP
QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q
 ;
X ;
 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
 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
 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
 I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA
 F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF
 G BAD:Y'?.E1":"
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
 ;G L:DUZ(0)="@"
 ;I $D(^DIC(3,"AFOF")) G ACC:'$D(^DIC(3,DUZ,"FOF",+DP,0)),ACC:'$P(^(0),U,6),L
 ;I $D(^DIC(+DP,0,"WR")) F D=1:1 S %=$E(^("WR"),D) I DUZ(0)[% Q:%]""  G ACC
L I $D(X)>1 S DXS=DXS+1,%=0 F  S %=$O(X(%)) Q:%=""  S @(DA_"%)=X(%)")
 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
 ;
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
 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'[";"
BAD Q:$D(DTOUT)  G X^DIA
ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD
 Q
 ;
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")
 S Y=0 F  S Y=$O(X(Y)) Q:Y=""  S @(DA_"Y)=X(Y)")
 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
 Q:DP'="@"  I DK="//" S DA=U_U Q
 W !,$C(7),"    WARNING: THIS MEANS AUTOMATIC DELETION!!"

DIAC
DIAC ;SFISC/YJK-FILE ACCESS CHECK ;9/14/94  10:00
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN Q:'$D(DIAC)!'$D(DIFILE)  I DUZ(0)="@" S (DIAC,%)=1 Q
 S A1=$S(DIAC="DD":2,DIAC="DEL":3,DIAC="LAYGO":4,DIAC="RD":5,DIAC="WR":6,DIAC="AUDIT":7,1:0) D:A1 CK
 K A1 S %=DIAC Q
 ;
CK I $S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D FOF Q
 I '$D(^DIC(DIFILE,0,DIAC)) S DIAC=1 Q
 S %=^(DIAC) I %="" S DIAC=1 Q
 F A1=1:1:$L(%) I DUZ(0)[$E(%,A1) S DIAC=1 Q
 I 'DIAC S DIAC=0
 Q
 ;
FOF S DIAC=0 I $S($D(^VA(200,DUZ,"FOF",DIFILE,0)):1,1:$D(^DIC(3,DUZ,"FOF",DIFILE,0))),$P(^(0),U,A1) S DIAC=1
 Q
 ;
 ;;

DIALOG
DIALOG ;SFISC/TKW - BUILD FILEMAN DIALOGUE ;9/30/94  10:52
V ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BLD(D0,DIPI,DIPE,DIALOGO,DIFLAG) ;BUILD FILEMAN DIALOG
 ;1)DIALOG file IEN, 2)Internal params, 3)External params, 4)Output array name, 5)S=Suppress blank line between messages, F=Format output like ^TMP
 N DINAKED S DINAKED=$$LGR^%ZOSV
 I $G(^DI(.84,+$G(D0),0))="" G Q1
 N E,I,J,K,L,M,N,P,R,S,X,O,DILANG S DILANG=+$G(DUZ("LANG")),DIFLAG=$G(DIFLAG)
 I $G(DIPI)]"",$O(DIPI(""))="" S DIPI(1)=DIPI
 I $G(DIPE)]"",$O(DIPE(""))="" S DIPE(1)=DIPE
 I '$O(^DI(.84,D0,4,DILANG,1,0))!('DILANG) S DILANG=1
 S P=$P(^DI(.84,+D0,0),U,3)["y",R=$P(^(0),U,2) S:'R R=1
 S O=$G(DIALOGO) S:O="" O="^TMP(",DIFLAG=DIFLAG_"F" D  S DIALOGO=O
 . S I=$E(O,$L(O)) I $E(O,1,4)="DIR(" S DIFLAG=$TR(DIFLAG,"F","")
 . I DIFLAG'["F" S O=$E(O,1,($L(O)-1))_$S(I="(":"",I=",":")",1:I) Q
 . S O=$P(O,")",1)_$S("(,"[I:"",O'["(":"(",1:",")_""""_$P("DIERR^DIMSG^DIHELP",U,R)_""""_$P(","_$J,U,O["^TMP(")_")"
 . Q
 S N=$O(@DIALOGO@(":"),-1)
 S N=N+1,(I,J,M)=0 S:R>1!(DIFLAG'["F") J=N-1
 I R=1,DIFLAG["F" S O=$P(O,")",1)_","_N_",""TEXT"")"
 I DILANG>1 F  S I=$O(^DI(.84,D0,4,DILANG,1,I)) Q:'I  S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM
 I DILANG'>1 F  S I=$O(^DI(.84,D0,2,I)) Q:'I  S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM
 G:'M Q2 D
 . N X S X=M
 . I N>1,DIFLAG'["S" I DIFLAG'["F"!(R>1) S J=J+1,@O@(J)=" ",X=X+1
 . I DIALOGO'["DIR" S:R=1 DIERR=($P($G(DIERR),U)+1)_U_($P($G(DIERR),U,2)+X) S:R=2 DIMSG=$G(DIMSG)+X S:R=3 DIHELP=$G(DIHELP)+X
 . D BTXT Q
 I (DIALOGO["DIR")!(R'=1)!(DIFLAG'["F") G Q2
 S @DIALOGO@(N)=D0
 S I="",J=0 F  S I=$O(DIPE(I)) Q:I=""  I $G(DIPE(I))]"" S @DIALOGO@(N,"PARAM",I)=DIPE(I),J=J+1
 I J S @DIALOGO@(N,"PARAM",0)=J
 S @DIALOGO@("E",D0,N)=""
 ;
Q2 I $G(^DI(.84,D0,6))]"" X ^(6)
Q1 Q:DINAKED=""  I DINAKED["(" Q:$O(@(DINAKED))  Q
 I $D(@(DINAKED))
 Q
 ;
PARAM S S=$F(K(M),"|",L) G:'S QP S E=$F(K(M),"|",S) G:'E QP
 S L=S,X=$E(K(M),S,E-2) G:X="" PARAM
 S DIPI(X)=$G(DIPI(X))
 I ($L(K(M))+$L(DIPI(X)))<245 S K(M)=$E(K(M),1,S-2)_DIPI(X)_$E(K(M),E,9999) G:K(M)]"" PARAM K K(M) S M=M-1 G QP
 I $L($E(K(M),1,S-2))+$L(DIPI(X))<245 S K(M+1)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2)_DIPI(X),M=M+1,L=0 G PARAM
 I $L(DIPI(X))+$L($E(K(M),E,9999))<245 S K(M+1)=DIPI(X)_$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+1,L=0 G PARAM
 S K(M+1)=DIPI(X),K(M+2)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+2,L=0
 G PARAM
QP Q
 ;
BTXT N M
 F M=0:0 S M=$O(K(M)) Q:'M  S J=J+1 D
 .I DIALOGO'["DIR" S @O@(J)=K(M) Q
 .I '$O(K(M)),'$O(^DI(.84,D0,2,I)) S @DIALOGO=K(M) Q
 .S @DIALOGO@(J)=K(M) Q
 Q
 ;
EZBLD(D0,DIPI) ;RETURN SINGLE LINE OF TEXT FROM DIALOG FILE.
 ;D0 = DIALOG file IEN, DIPI = Input Params
 N DINAKED S DINAKED=$$LGR^%ZOSV I $G(^DI(.84,+$G(D0),0))="" D Q1 Q ""
 N DILANG S DILANG=+$G(DUZ("LANG"))
 N X I DILANG>1 S X=$O(^DI(.84,+D0,4,DILANG,1,0)) S:X X=$G(^(X,0))
 I $G(X)']"" S X=$O(^DI(.84,+D0,2,0)) S:X X=$G(^(X,0))
 I ($P(^DI(.84,+D0,0),"^",3)'["y"!($G(X)="")) S X=$G(X) G QEZ
 N K,S,L,M,I,E S M=1,L=0,K(M)=X
 I $G(DIPI)]"",$O(DIPI(""))="" S DIPI(1)=DIPI
 D PARAM S X=$G(K(1))
QEZ D  Q X
 . N X D Q2 Q
 ;
 ;
MSG(DIFLGS,DIOUT,DIMARGIN,DICOLUMN,DIINNAME) ;WRITE MESSAGES OR MOVE THEM TO SIMPLE ARRAY.
 ;1)Flags, 2)Output array name, 3)Margin width of text, 4)Starting column no., 5)Input array name.
 N Z,%,X,Y,I,J,K,N,DITYP,DIWIDTH,DITMP,DIIN,DINAKED S DINAKED=$$LGR^%ZOSV
 S:$G(DIFLGS)="" DIFLGS="W" D
 . S DITMP=0 I $G(DIINNAME)="" S DIINNAME="^TMP(",DITMP=1 Q
 . N % S %=DIINNAME I %'["(" S DIINNAME=DIINNAME_"(" Q
 . Q:$E(%,$L(%))=","
 . I $E(%,$L(%))=")" S DIINNAME=$P(%,")",1)_"," Q
 . S DIINNAME=%_"," Q
 S DITYP="",%=0 D
 . F Z="E","H","M" S %=%+1 I DIFLGS[Z,$D(@(DIINNAME_""""_$P("DIERR^DIHELP^DIMSG",U,%)_""""_$P(","_$J,U,(DITMP>0))_")")) S $P(DITYP,U,%)=$P("DIERR^DIHELP^DIMSG",U,%)
 . I DITYP="",$D(@(DIINNAME_"""DIERR"""_$P(","_$J,U,(DITMP>0))_")")) S DITYP="DIERR"
 . Q
 S DIWIDTH=$S($G(DIMARGIN):DIMARGIN,$G(IOM):(IOM-5),1:75),DICOLUMN=+$G(DICOLUMN)
 K:DIFLGS["A" DIOUT S (K,Z)=0
AWS S K=K+1 I K>3 G Q1
 G:$P(DITYP,U,K)="" AWS
 S DIIN=DIINNAME_""""_$P(DITYP,U,K)_"""" S:DITMP DIIN=DIIN_","_$J
 S (I,N)=0
 F  S N=$O(@(DIIN_")")@(N)) Q:'N  S:K>1 X=$G(@(DIIN_","_N_")")) D:K>1  I K=1 D:I&(DIFLGS'["B") LN S I=1,J=0 F  S J=$O(@(DIIN_")")@(N,"TEXT",J)) Q:'J  S X=$G(@(DIIN_","_N_",""TEXT"","_J_")")) D
 . I DIFLGS["A",'$G(DIMARGIN) S Z=Z+1,DIOUT(Z)=X
 . I DIFLGS'["W",'$G(DIMARGIN) Q
 . S Y=X D:X=""  F  Q:X=""  F %=$L(X," "):-1:1 S:%=1&($L($P(X," ",1,%))>DIWIDTH) X=$E(X,1,(DIWIDTH-1))_" "_$E(X,DIWIDTH,$L(X)),%=%+1 I $L($P(X," ",1,%))'>DIWIDTH S Y=$P(X," ",1,%) D  S X=$P(X," ",%+1,$L(X," ")) Q
 .. W:DIFLGS["W" !?DICOLUMN,Y S:DIFLGS["A"&$G(DIMARGIN) Z=Z+1,DIOUT(Z)=Y
 .. Q
 . Q
 F I=K:1:2 I $P(DITYP,U,I+1)]"" D LN Q
 I DIFLGS["A",DIFLGS["T" S DIOUT=Z
 I DIFLGS'["S" K @(DIIN_")"),@($P(DITYP,U,K))
 G AWS
 ;
LN W:DIFLGS["W" ! S:(DIFLGS["A")&Z Z=Z+1,DIOUT(Z)="" Q

DIALOGU
DIALOGU ;SFISC/MMW - FUNCTIONS FOR DIALOGS ;11/21/94  13:26
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q  ;not for interactive use
OUT(Y,DIALF,%F) ;convert FileMan Data to language dependant output format
 ;Y is the value to transform, DIALF is the type of data
 ;%F Only for "FMTE" node. Passed from FMTE^DILIBF, indicates date format.
 ;DIALF must correspond to at least a subscript in the language file
 ;for the english language (entry #1) but may also have corresponding
 ;entries for other languages
 I $D(Y)[0!($G(DIALF)="") Q ""
 N DINAKED,DIY S DINAKED=$$LGR^%ZOSV
 N DILANG S DILANG=+$G(DUZ("LANG")) S:DILANG<1 DILANG=1
 S DIY=$G(^DI(.85,DILANG,DIALF)) I DIY="" S:DILANG'=1 DIY=$G(^DI(.85,1,DIALF)) I DIY="" S Y="" G Q
 X DIY
Q D:DINAKED]""
 . I DINAKED["(" Q:$O(@(DINAKED))  Q
 . I $D(@(DINAKED))
 . Q
 Q Y
 ;
PRS(D0,X) ;parse language dependant user input
 ;D0 is an entry in the DIALOG file
 ;X is the user input
 ;the function returns the number of the matching command word
 ;plus the corresponding english text. If no match was found -1 will
 ;be returned. If there is no user input the function returns the
 ;null string.
 N DINAKED,Y S DINAKED=$$LGR^%ZOSV
 I '$D(^DI(.84,+$G(D0)))!($G(X)']"") S Y=0 G Q
 N R,I,I1,IL,T,W,%,DILANG
 S DILANG=+$G(DUZ("LANG")) S:DILANG<1 DILANG=1
 I DILANG>1,'$O(^DI(.84,D0,4,DILANG,1,0)) S DILANG=1
 S X=$$OUT(X,"UC"),U="^"
 S R=$S(DILANG=1:"^DI(.84,"_D0_",2)",1:"^DI(.84,"_D0_",4,"_DILANG_",1)")
 S (I,I1,%)=0 F  S I=$O(@R@(I)) Q:'I!%  S T=$$OUT(@R@(I,0),"UC") D
 .F IL=1:1 S W=$P(T,U,IL) Q:W=""!%  S I1=I1+1 S:$E(W,1,$L(X))=X %=I1_U_$P(@R@(I,0),U,IL)
 I '% S Y=-1 G Q
 I DILANG=1 S Y=% G Q
 S (I,I1)=0,%=+% F  S I=$O(^DI(.84,D0,2,I)) Q:'I!(I1=%)  S T=^(I,0) D
 .F IL=1:1 Q:$P(T,U,IL)=""!(I1=%)  S I1=I1+1,W=$P(T,U,IL)
 S Y=%_U_$G(W) G Q

DIAR
DIAR ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS ;7/1/93  4:17 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G NOKL
 ;
1 ;;SELECT ENTRIES TO ARCHIVE
 S DIAR=1 D DIAR^DICRW G Q:Y<0 S %=$P(Y,U,2),(Y,DIARF,DIART)=+Y
 ;TEMPORARY CHANGE TO SKIP SUB-FILE OPTION--NOT COMPLETE
 G O
 G O:'$O(^DD(DIARF,"SB",0))
 W !!,"IF YOU PLAN TO ARCHIVE DATA ONLY FROM ONE SUB-FILE"
 W !,"PLEASE IDENTIFY IT HERE.  OTHERWISE, JUST PRESS RETURN.",!
 D SUB^DICRW G Q:$D(DTOUT)!$D(DUOUT),O:'$D(DIA) S DIARF=DIA
 S DIARF0="D0," F D=1:1 Q:'$D(^DD(DIA,0,"UP"))  S DIARF0=DIARF0_"D"_D_",",DIA=^("UP")
O S I="" D CHK
 I '$D(DIARC) D NEW^DIARCALC G Q:'$D(DIARC) G T1
 I $P(Y(0),U,7)>0 W !!,"There is already an outstanding "_$S(+$P(Y(0),U,17):"extract",1:"archiving")_" activity.",!,"Please finish it or CANCEL it.",$C(7),!! G Q
 D MRK^DIARU
T1 S DIC=DIART,L="]" I $D(DIARF0) S DIARF1=$L(DIARF0,",")-1
 D EN^DIS I '$P(^DIAR(1.11,DIARC,0),U,7) W $C(7),!!,"NO RECORDS WERE SELECTED TO BE "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"!!",!,"I AM DELETING THIS ARCHIVING ACTIVITY RECORD!!" S DIK="^DIAR(1.11,",DA=DIARC D ^DIK
 G Q
 ;
CHK ;IS THERE A VALID SEARCH ?
 K DIARC,Y(0) S I=0,Y=$S($D(DIARF):DIARF,1:Y)
C S I=$O(^DIAR(1.11,"C",+Y,I)) Q:'I  S Y(0)=""
 G C:'$D(^DIAR(1.11,I,0)) G C:$P(^(0),U,8)>89 S Y(0)=^(0)
 S DIC=$P(Y(0),U,2),DIARC=I,DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4)
 Q
2 ;;ADD/DELETE SELECTED ENTRIES
 S DIAR=2 G ENTE^DIARB
 ;
3 ;;PRINT SELECTED ENTRIES
 S DIAR=3 G OUT^DIARA
 ;
4 ;;CREATE FILEGRAM ARCHIVING TEMPLATE
 S DI=1,DIAR="" G EN^DIFGO
 ;
5 ;;WRITE ENTRIES TO TEMPORARY STORAGE
 S DIAR=4 G OUT^DIARA
 ;
 ;
6 ;;MOVE ARCHIVED DATA TO PERMANENT STORAGE
 S DIAR=5 D FILE^DIARU G Q:'$D(DIARC)
 W !!,"NOTE: This option will 1) print an archive activity report to specified",!,"PRINTER DEVICE and 2) will move archive data to permanent storage to specified",!,"ARCHIVE STORAGE DEVICE."
 W !!,"Select some type of SEQUENTIAL media, such as SDP, TAPE, or DISK FILE (HFS),",!,"for archival storage.",!
 S %ZIS("A")="PRINTER DEVICE: ",%ZIS("B")="",%ZIS="NQ" D ^%ZIS G 65:POP S DIARPDEV=$S($D(ION)#2:ION,1:IO),DIARTRM=$S(IO=IO(0):1,1:0)
 I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST
 F DIARX="IOM","IOSL" S:($D(@DIARX)#2&@DIARX) DIARPDEV=DIARPDEV_";"_@DIARX
 I $D(IO("Q")) S DIARQUED=1
 S %ZIS="Q",%ZIS("B")="",%ZIS("A")="ARCHIVE STORAGE DEVICE: " D ^%ZIS G 65:POP
 I IOT'["HFS",IOT'["MT",IOT'["SDP" D 63 I $D(DIRUT)!('Y) D 64 G 65
 I $D(IO("Q")),DIARTRM U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, YOU SHOULD SELECT A PRINTER DEVICE",!,"OTHER THAN YOUR TERMINAL!",! G 65
 D AL I $D(DTOUT)!$D(DIRUT) D 64 G 65
 I $D(IO("Q")) D  G Q
 . I '$D(DIARQUED),'DIARTRM S DIARQUED=1 U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, REPORT WILL BE QUEUED ALSO!",!
 . S ZTRTN="62^DIAR",ZTSAVE("DIARC")="",ZTSAVE("DIAR")="",ZTDESC="Move archived data to permanent storage",ZTSAVE("DIARPDEV")="",ZTSAVE("DIARQUED")=""
 . D ^%ZTLOAD,HOME^%ZIS Q
62 D ^DIARX
 S DIARL="F  Q:$A(DIARLINE)-32  S DIARLINE=$E(DIARLINE,2,999)"
 U IO F I=0:0 S I=$O(^DIAR(1.11,DIARC,"D",I)) Q:I'>0  I $D(^(I,0)) S DIARLINE=^(0) X:$E(DIARLINE)[" " DIARL W DIARLINE,!
 W "#$#",!
 D 64,OUT^DIARX,UPDATE^DIARU
 G Q
63 U IO(0) W !,$C(7),"The ARCHIVE STORAGE device selected does not look like a SEQUENTIAL",!,"storage medium.",!
 K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to continue" D ^DIR
 I Y U IO(0) W !,"OK.",!
 Q
64 X $G(^%ZIS("C"))
 Q
65 ;
 G UNLK^DIARA
 ;
7 ;;PURGE STORED ENTRIES
D S DIAR=90 G ENTD^DIARA
 ;
8 ;;CANCEL ARCHIVAL SELECTION
 S DIAR=99 G ENTC^DIARA
 ;
9 ;;FIND ARCHIVED ENTRIES
 S DIC=9.4,DIC(0)="QM",DIC("S")="I $P(^(0),U,2)=""XU""",X="KERNEL" D ^DIC K X,DIC I Y'>0 W !,$C(7),"YOU NEED KERNEL TO RUN THIS OPTION" Q
 I $G(^DIC(9.4,+Y,"VERSION"))'>7.0 W !,$C(7),"YOU NEED KERNEL V7.1 TO RUN THIS OPTION" Q
 G ^DIARR
 ;
Q G Q^DIARB
 ;
AL ; archive device label
 U IO(0) K DIR,DA
 S DIARXXX=$S(IOT["MT":IO_"ARCHIVE"_";"_DT_";"_DIARC,1:IO)
 S DIR(0)="1.11,18",DIR("B")=DIARXXX D ^DIR Q:$D(DTOUT)!$D(DUOUT)
 S DIARXXX=X,DIE=1.11,DA=DIARC,DR="18////^S X=DIARXXX" D ^DIE
 Q
NOKL S DIK="^DOPT(""DIAR""," G GO:$D(^DOPT("DIAR",9))
 S ^(0)="ARCHIVE OPTION^1.01^" K ^("B")
 F I=1:1:9 S ^DOPT("DIAR",I,0)=$P($T(@I),";;",2)
 D IXALL^DIK
GO W ! S DIC=DIK,DIC(0)="AEQI" D ^DIC K DIC,DIK
 I Y'<0 S X=+Y K Y D @X G NOKL
 W ! G Q^DII

DIARA
DIARA ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;5/30/96  14:25
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ENTD ; PURGE
 W:'$D(DIAX) !!,$C(7),$C(7),"BEFORE YOU PURGE, MAKE SURE THAT YOUR ARCHIVE MEDIUM IS READABLE!",!,"YOU MAY USE THE FIND ARCHIVED ENTRIES OPTION TO FIND THE LAST",!,"ARCHIVED RECORD APPEARING ON THE INDEX.",!
 K DIR S DIR(0)="Y",DIR("A")="Do you want to proceed",DIR("B")="NO" D ^DIR Q:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1)
 D FILE^DIARU G Q:'$D(DIARC)
 I $D(^DD(DIARF,0,"PT")) W !!,$C(7),"The records about to be purged should not be 'pointed to' by other records to",!,"maintain database integrity."
 W ! K DIR S DIR(0)="Y",DIR("A",1)="This option will DELETE DATA from both "_$P(^DIC(DIARF,0),U),DIR("A",2)="and from the ARCHIVAL ACTIVITY file.",DIR("A")="Are you sure you want to continue",DIR("B")="NO"
 D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1)
 S DIFILE=DIARF,DIAC="DEL" D ^DIAC I '% W !,$C(7),"Sorry, you cannot purge this archival activity!",!,"You do not have DELETE access to ",$P(^DIC(DIARF,0),U),"." G UNLK
 W !!,"The entries will be deleted in INTERNAL NUMBER order."
 S DIARS="" F K="ID","SP" F I=0:0 S I=$O(^DD(DIARF,0,K,I)) Q:+I'=I  I $D(^DD(DIARF,I,0))#2 S X=$P(^(0),U,4) I $P(X,";")=0 S DIARS=DIARS_$P(X,";",2)_U
D0 S DA=$O(^DIBT(DIARU,1,0))
 I DA="" W !!,"<< ",$P(^DIAR(1.11,DIARC,0),U,7)," ENTRIES PURGED >>" K ^("D"),^("EX") D UPDATE^DIARU G Q
 S DIK=DIC,DIARS(0)=$S($D(@(DIC_"DA,0)")):^(0),1:"") K ^DIBT(DIARU,1,DA)
 I DIARS(0)="" S Y=$P(^DIAR(1.11,DIARC,0),U,7),$P(^(0),U,7)=Y-1 G D0
 D ^DIK G D0:DIARF'=DIARF2 S Y=DIARS(0),X=$P(Y,U) G E:'$D(DIARS)#2
D F I=1:1 Q:$P(DIARS,U,I)=""  S %=$P(DIARS,U,I),$P(X,U,%)=$P(Y,U,%)
E ;SETS -9 NODE & STUB IN ORIGINAL FILE.  NOT DONE FOR V18
 ;S @(DIC_"DA,-9)")=DIARC,^(0)=X
 G D0
 ;
ENTC ;CANCEL
 S DIC("A")="CANCEL WHICH "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" SELECTION: " D FILE^DIARU G Q:'$D(DIARC)
 S DIR("A")="Are you sure you want to CANCEL this "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" ACTIVITY",DIR("B")="NO",DIR(0)="Y"
 S DIR("??")="^W !!?5,""Enter YES to stop this activity and start again from the beginning."""
 D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT),UNLK:'Y
 F I=0:0 S I=$O(^DIBT(+DIARU,1,I)) Q:'I  K @(DIC_I_",-9)")
 I $D(DIAX) S DIAXNRB=0 I DIARST=6,$D(^DIAR(1.11,DIARC,"EX")) D ASK^DIARB G UNLK:$D(DUOUT)!$D(DTOUT) I 'DIAXNRB,$D(^DIAR(1.11,DIARC,"EX")) S DIK=^DIC(DIAXFNO,0,"GL"),DA=0,DIOVRD=1 F  S DA=$O(^DIAR(1.11,DIARC,"EX","B",DA)) Q:DA'>0  D ^DIK
 S DIK="^DIAR(1.11,",DA=DIARC D ^DIK W !!,">>> DONE <<<"
 G Q
 ;
OUT ;USED TO PRINT LISTING OR TO WRITE TO TEMP.STORAGE
 K DIARC,FLDS D FILE^DIARU G Q:'$D(DIARC)
 S DIARD=0 W !!
 D @DIAR
 I DIAR'=3 K DIARP S DIE="^DIAR(1.11,",DA=DIARC,DR="3;S DIARP=X" D ^DIE G UNLK:$D(DTOUT)!'$D(DIARP) S FLDS="[`"_DIARP_"]"
 S FR="",TO="",L=0 K DIOEND S:(DIAR'=3) DIOEND="W !,$P(^DIAR(1.11,DIARC,0),U,7)"_","""_" ITEMS HAVE BEEN "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"""",DISTOP=0
 K DIE,DR,DA S BY="[`"_DIARU_"]",DIARI=DIARU S:DIAR=3 BY=BY_",.01"
 S DHD=$P(^DIC(DIARF,0),U)_$S($D(DIAX):" EXTRACT",1:" ARCHIVING")_" ACTIVITY",DIC=^(0,"GL")
 F %=0:0 S %=$O(^DIAR(1.11,DIARC,"S",%)) Q:%'>0  S DIFG(+DIARF2,^(%,0))=^(1)
 S %=$O(DIFG(+DIARF2,"")) K:%="" DIFG
 I $D(DIFG) S DIFG(+DIARF2,"S")="X DIFG("_+DIARF2_","_%_")"
 D EN1^DIP
 I DIAR'=3,$G(POP) G UNLK
 G Q
UNLK S DIAR="" D UPDATE^DIARU
Q K POP G Q^DIARB
 ;
3 W "Enter regular Print Template name or fields you wish to see printed on this",!,"report of entries to be "_$S($D(DIAX):"extracted.",1:"archived.") Q
4 W "You MUST enter a FILEGRAM template name.  This FILEGRAM template will be used",!,"to actually build the archive message." Q

DIARB
DIARB ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;4/24/96  10:55
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ENTE ;ADD/REMOVE ENTRIES TO SELECTED
 S DIC("A")="ADD/DELETE ENTRIES FROM ARCHIVAL ACTIVITY: " K DIARC D FILE^DIARU G Q:'$D(DIARC)
 S DIARCNT=0 K DIC
D S DIC=+DIARF,DIC(0)="AEQMF",DIART=DIARF2,Z=0
E W ! S DIC("W")="W:$D(^DIBT(DIARU,1,+Y)) "" *on "_$S($D(DIAX):"EXTRACT",1:"ARCHIVE")_" list*"" S DIARX="""" F DIARX2=0:0 S DIARX=$O(^DD(+DIARF,0,""ID"",DIARX)) Q:DIARX=""""  S DIARX3=^(DIARX) I $D(@(DIC_""+Y,0)"")) X DIARX3"
 D ^DIC K DIC("W")
 I Y'>0 G QE
 S X=DIART G F:'X S Z=Z+1,%=$P($P(X,U,2),",",Z)
 G F:'% S $P(X,U)=$P($P(X,U),",",2,999),DIC=DIC_+Y_","_%_","
 I $D(@(DIC_"0)")),$P(^(0),U,2)-X=0 S DIART=X G E
 W !,$C(7),"No "_$O(^DD(+X,0,"NM",""))_" entry !!!",!
 G D
F K DR S DA=+Y,DR=0 D EN^DIQ
 I '$D(^DIBT(DIARU,1,DA)) G E1
 S DIR(0)="Y",DIR("A")="DELETE this entry FROM the "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" SELECTION",DIR("B")="YES"
 D ^DIR G QE:$D(DUOUT)!$D(DTOUT),QE:'$D(Y)
 I 'Y W !!,"OK, I left it IN !" G D
 S DIARCNT=DIARCNT+1,A=^DIAR(1.11,DIARC,0),$P(A,U,7)=$P(A,U,7)-1,$P(A,U,8)=2,^(0)=A
 K ^DIBT(DIARU,1,DA),@(DIC_DA_",-9)") W "  Deleted"
 G D
E1 S DIR(0)="Y",DIR("A")="ADD this entry TO the "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" SELECTION",DIR("B")="YES"
 D ^DIR G QE:$D(DUOUT)!$D(DTOUT),QE:'$D(Y)
 I 'Y W !!,"OK, I left it OUT !" G D
 S DIARCNT=DIARCNT+1,A=^DIAR(1.11,DIARC,0),$P(A,U,7)=$P(A,U,7)+1,$P(A,U,8)=2,^(0)=A
 S ^DIBT(DIARU,1,DA)="" W "  DONE"
 G D
QE S:'DIARCNT DIAR="" D UPDATE^DIARU
Q K DIAR,DIARC,DIARCNT,DIARD,DIARE,DIARF,DIARF0,DIARF1,DIARF2,DIARI,DIARP,DIARS,DIARST,DIART,DIARU,DIARX,DIAR
 K DIR,DIC,DIARL,DIARLINE,DIARBLNE,DIARPDEV,DIARPG,DIAX,DIAXFNO,DIAXNRB,DIAXMSG,DIARQUED,DIARTAB,DIARTRM,DIARXZ,DIARFLD,DIARFI,DIARXY
 K DIFILE,DIARXXX,DISTOP,DIARX2,DIARX3,DIPG,DIERR,DIOVRD
 Q
ASK W !!,$C(7),"This extract activity has already updated the destination file.",!
 S DIR("A")="Delete the destination file entries created by this extract activity",DIR("B")="NO",DIR(0)="Y"
 S DIR("??")="^W !!?5,""Enter YES to rollback the destination file to its state before the update."""
 D ^DIR I 'Y S DIAXNRB=1
 Q

DIARCALC
DIARCALC ;SFISC/TKW,WISC/CAP-ARCHIVING Variables Doc / Misc Calc. ;11/3/92  4:19 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;COMPUTE BOUNDARIES
FROM ;SELECT FROM VALUE 4 SORT
 S X="F" D G
 I $D(DIARS) S:A="" A=$P(DIARS,U,2) S:A="" A="FIRST" G Q
 D H Q:X=""  S DIARS=Y_U_X Q
TO ;SELECT TO VALUE 4 SORT
 S X="T" D G
 I $D(DIARE) S:A="" A=$P(DIARE,U,2) S:A="" A="LAST" G Q
 D H Q:X=""  S DIARE=Y_U_X Q
G S DIART=L,L=0 I $D(DIPP(DJ,X)) S A=$P(DIPP(DJ,X),U,2) Q
 I $D(DPP(DJ,X)) S A=$P(DPP(DJ,X),U,2) Q
 S A="" Q
H ;
 S %=X,%1=DISV
 I +%1,$D(^DIBT(%1,2,DJ,%)) S (X,%2)=$P(^(%),U,2) I "z"'[X
 E  S %2=$S(%="T":"LAST",1:"FIRST"),X=""
 I X="",'$D(DIAR) S A=%2,L=DIART G Q
 D CK:X'=""
 S L=DIART,A=$S(%="F"&(X]%2):X,%="T"&(%2]X)&(X'=""):X,A'="":A,1:%2)
Q K %,%1,%2,DIART Q
 ;
NEW ;SET UP INITIAL ARCHIVAL ACTIVITY
 D NOW^%DTC
 S X=$P(^DIAR(1.11,0),U,3) F X=X:1 L +^DIAR(1.11,X):0 Q:$T&'$D(^(X))  L -^DIAR(1.11,X)
 S Z="1////"_DIART_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";30////"_DIARF_";13////"_DIAR_";14////"_%_$S($D(^VA(200)):";15////"_DUZ,1:"")_";16////"_$S($D(DIAX):1,1:0)
 I $D(DIARF0) S Z=Z_";31////"_DIARF0
 S DINUM=X,DIC("DR")=Z
 S DIC="^DIAR(1.11,",DIC(0)="EF"
 D FILE^DICN S DIARC=+Y K DR
 Q
 ;
CK S DIART=%_U_%2_U_A D CK^DIP12
 S %=$P(DIART,U,1),%2=$P(DIART,U,2),A=$P(DIART,U,3) Q
VAR ;
 ;DIAR0 = List of human readable conditions from ^DOPT("DIS" in ^ pieces
 ;DIARC = Internal record number of Archival Activity
 ;DIARD = Array of information from default package archival search
 ;        template for this file.  (Created in DIAR0)
 ;DIARDC= Number of default conditions
 ;DIARE = To value in DIP sort questions
 ;DIARF = Internal number of file being archived
 ;DIARF0= Subfile List or DIAR/DIBT INDEX
 ;DIARI = SEARCH TEMPLATE USED
 ;DIARF1=Level # that search is on
 ;DIARP = Internal record no. of Filegram template
 ;DIARS = Temporary value / From value in DIP sort questions
 ;DIART = Temporary storage variable
 ;DIARU = Internal number of Select Criteria Template
 ;DIARST = Archival Activity upon entry to archival option

DIARR
DIARR ;SFISC/DCM-ARCHIVING FUNCTION, RETRIEVAL OF ARCHIVED RECORD ;3/24/93  3:20 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START W !!,"This option will scan your archived file and will attempt to retrieve entries"
 W !,"that match the name (.01) field and/or the identifier field(s) of the archived",!,"file."
 W !!,"Magnetic tapes should be opened with variable length records."
 ;
INIT S DIARX="F  U DIARIO R DIARL Q:DIARL]""""&($A(DIARL)'=13)  "
 D HOME^%ZIS S DIOF=IOF,DIOSL=IOSL
 D DT^DICRW
 K ^TMP("DIAR",$J)
 S (DIARREQ,DIAROUT,DIARZ,DIAREOF,DIARMTCH,DIARFGEN,DIARPG,DIARRCT,DIARZID,DIARZL,DIARZ1,DIARZ2,DIARX1,DIARY,DIARNM,DIARRCT,DIARFND,DIARRHP)=0,DIARLINE=""
 ;
SEQDEV S %ZIS("A")="SEQUENTIAL ARCHIVE DEVICE: ",%ZIS("HFSMODE")="R" D ^%ZIS G EOJ:POP
 I IOT'["MT",IOT'["SDP",IOT'["HFS" D ^%ZISC W !,$C(7),"This has to be a sequential device." G SEQDEV
 I IOT["MT",IOPAR'["V" D ^%ZISC W !,$C(7),"Open this device with variable length records." G SEQDEV
 S DIARIO=IO
 ;
RC X DIARX I $E(DIARL,1,4)'["$IND"&($E(DIARL,1,4)'["$DAT") D ^%ZISC W !,$C(7),"Archive information is not in filegram format" G SEQDEV
 I $E(DIARL,1,6)="$INDEX" S DIARIDX=1 D ^DIARR6 G RC3
 U IO(0) W !!,"Sampling archived file...",!
RC2 I $P(DIARL,U)="$DAT" S DIARFILE=$P(DIARL,U,2),DIARFN=+$P(DIARL,U,3)
 X DIARX S DIARNAME=$P(DIARL,"=",2) X DIARX
 F  X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN))  D RC1:$P(DIARL,":")="BEGIN" I ($P($P(DIARL,U),":")="IDENTIFIER")!($P($P(DIARL,U),":")="SPECIFIER") D ID
 F  X DIARX Q:$P(DIARL,U)["$END DAT"  I +$P(DIARL,U,2)=".01" S DIAR01=$P(DIARL,U) S ^TMP("DIARHLP",$J,DIARRCT+1,.01)=DIAR01_" = "_$P(DIARL,"=",2) Q
 I '$D(DIAR01) S DIARNM=1,^TMP("DIARHLP",$J,DIARRCT+1,.01)="NAME = "_DIARNAME
 S DIARRCT=DIARRCT+1
 F  X DIARX  Q:((DIARL["#$#")!(DIARRCT>5))  G RC2:((DIARRCT'>5)&($P(DIARL,U)["$DAT"))
 ;
RC3 I DIARNM,'$D(DIAR01) S DIAR01="NAME"
 S DIARXXX=$$REWIND^%ZIS(IO,IOT,IOPAR)
 ;
FILE U IO(0) W !,"You are reading archived information from the "_DIARFILE_" file."
 K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to continue"
 D ^DIR G EOJ:'Y!($D(DIRUT))
 ;
 D ^DIARR1 G EOJ:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))!POP K DIRUT,DUOUT
 D ^DIARR2
 D ^DIARR3
 D ^DIARR5
 D EOJ
 Q
 ;
ID S DIARID(+$P(DIARL,U,2))=$P($P(DIARL,U),":",2)_U_+$P(DIARL,U,2)
 S ^TMP("DIARHLP",$J,DIARRCT+1,$P($P(DIARL,U),":",2))=$P($P(DIARL,U),":",2)_" = "_$P(DIARL,"=",2)
 Q
 ;
RC1 S DIARFN1=+$P(DIARL,U,2)
 F  X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN1))
 Q
 ;
EOJ D ^%ZISC
 K POP,DIARX,DIARFILE,DIARFN,DIARIO,DIARID,DIAR01,DIARZ,DIARREQ,DIARR,DIR,DIRUT,DTOUT,DUOUT,%MT,DIAROUT,DIARPDEV
 K DIARL,DIARA,DIAREOF,DIARF2,DIARFGEN,DIARFGL,DIARMTCH,DIARNM,DIARY,DIARIDDN,DIARMTID,DIARMT01,DIARZID
 K ^TMP("DIAR",$J),DIARRF,DIARZ1,DIARZ2,DIARRCT,DIARPG,DIARZL,DIARX1,DIARLINE,DIARIDS,DIARQUED,DIARFN1
 K DIARHLP,DIARRHP,DIARZHP,DIARNAME,DIAROFLD,DIAROIDF,DIAROAT,DIAROFLD,DIAROIDF,DIAROLVL,DIAROSTK,DIAROVAL,DIAROXPL
 K DIAROLNE,DIAROLUP,DIAROM,DIAROREQ,DIAROSUB,DIAROTAB,DIAROX,DIAROX1,DIAROZ,DIARZZ,DIARTAB,DIAROBPT,^TMP("DIARO",$J)
 K DIAROBCK,DIAROBF,DIAROBFN,DIAROBF1,DIAROSF,DIAROSFN,DIAROXX,DIARCNT,DIARCTR,DIARFLD,DIARFLGT,DIARFNA,DIARFNO,DIARIDX
 K DIARIXCT,DIARIXX,DIARPC,DIARREC,DIARVAL,DIARXX,DIARFND,DIARYY,DIARXXX,^TMP("DIARHLP",$J),DIAROX2,DIOF,DIOSL
 Q

DIARR1
DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93  8:43 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PROC D N Q:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))
 D PRINTDEV Q:POP
 I '$D(IO("Q")) U IO(0) W !,"Searching archived file..."
 Q
 ;
N U IO(0) I '$D(DIARIDX) W !!,"Type ?? at any prompt to display sampled entries.",!
 W !!,"Multiple requests may be made.",!,"One set of all prompts makes one request.",!
 I $D(DIARIDX) D ASKIX Q:$D(DIRUT)
N1 W !
 K DIR S DIR("?",1)="Enter the "_DIAR01_" (.01) field.",DIR("?",2)="Answer to this prompt will retrieve all entries that match the ",DIR("?")=DIAR01_" field.",DIR("??")="^D HELP^DIARR1"
 S DIR(0)="FO",DIR("A")="Enter "_DIAR01 D ^DIR
 S:((X]"")&(X'="^")) DIARR(DIARREQ+1,".01")=X
 Q:$D(DTOUT)!(DIAROUT&(X=""))!($D(DUOUT))!('$D(DIARID)&$D(DIRUT))
 I $D(DIARID) D IDS Q:$D(DTOUT)
 S:$D(DIARR(DIARREQ+1)) DIARREQ=DIARREQ+1 G N1
 ;
IDS S DIAROUT=0
 K DIR S DIR(0)="FO",DIR("?",1)="Enter identifier information.  Answer to this prompt, along with all",DIR("?",2)="previously answered prompts for this request, will be used in the matching",DIR("?")="process."
 S DIR("??")="^D HELP^DIARR1"
 F DIARZ=.019:0 S DIARZ=$O(DIARID(DIARZ)) Q:DIARZ'>0  S DIR("A")="Enter "_$P(DIARID(DIARZ),U)_" (id) " D ^DIR Q:$D(DTOUT)!$D(DUOUT)  S:((X]"")&(X'="^")) DIARR(DIARREQ+1,"ID",+$P(DIARID(DIARZ),U,2))=X
 I '$D(DIARR(DIARREQ+1)) S DIAROUT=1 Q
 Q
 ;
HELP S DIARZHP="" W @DIOF
 F DIARHLP=0:0 S DIARHLP=$O(^TMP("DIARHLP",$J,DIARHLP)) Q:DIARHLP'>0!$D(DTOUT)!$D(DIRUT)  W ! F  S DIARZHP=$O(^TMP("DIARHLP",$J,DIARHLP,DIARZHP)) Q:DIARZHP=""  W !,^(DIARZHP) I $Y>(DIOSL-3) D E Q:$D(DTOUT)!$D(DIRUT)
 Q
 ;
E ;
 N DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DIRUT)
 W @DIOF
 Q
 ;
PRINTDEV Q:'$D(DIARR)
 S %ZIS="QN",%ZIS("B")="",%ZIS("A")="PRINT FOUND ENTRIES TO DEVICE: " D ^%ZIS Q:POP
 S DIARPDEV=$S($D(ION)#2:ION,1:IO)
 I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST
 F DIARZ="IOM","IOSL" S:($D(@DIARZ)#2&DIARZ) DIARPDEV=DIARPDEV_";"_@DIARZ
 I $D(IO("Q")) U IO(0) W !,"THE PRINTING OF REPORT WILL BE QUEUED.  PROCESSING CONTINUES..." S DIARQUED=""
 Q
 ;
ASKIX W !,"This archived file contains an index of all archived entries."
 K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to see the index now" D ^DIR Q:'Y!($D(DIRUT))
 W @DIOF,! S DIARTAB=0 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARPC(DIARXX),U,2),DIARTAB=DIARTAB+25 W $E(DIARFLD,1,23),?DIARTAB
 S DIARYY=""
 W ! F DIARXX=1:1:DIARCTR W ! S DIARTAB=0 D  I $Y>(DIOSL-2) D E Q:$D(DTOUT)!$D(DIRUT)
 . F  S DIARYY=$O(DIARPC(DIARYY)) Q:DIARYY'>0  S DIARFLD=+$G(DIARPC(DIARYY)),DIARTAB=DIARTAB+25 W $E($P($G(^TMP("DIARHLP",$J,DIARXX,DIARFLD)),"= ",2),1,23),?DIARTAB
 . Q
 K DTOUT,DIRUT
 Q

DIARR2
DIARR2 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG) PROCESS REQUEST ;11/18/92  11:29 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $D(DIARIDX) D PROC^DIARR6 G C
 ;
FG F DIARZ=1:1 X DIARX Q:(DIARL="#$#")  S ^TMP("DIARFG",$J,DIARZ)=DIARL D:DIARL="$END DAT" FG1
C S X=DIARIO X ^DD("FUNC",7,1) K:$D(DIARIO)#2&(DIARIO]"") IO(1,DIARIO)
 D EOP
 Q
 ;
FG1 F DIARZ=1:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:((DIARFGL="$END DAT")!(DIARFGEN))  D FG2
 D IDS
 D MATCH
 D EOP
 Q
 ;
FG2 Q:$P(DIARFGL,U)="$DAT"
 I DIARNM,$P(DIARFGL,U)=DIARFILE S DIARA(".01")=$P(DIARFGL,"=",2) Q
 I $P(DIARFGL,":")="BEGIN" D FG3 Q
 I $P(DIARFGL,":")="IDENTIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q
 I $P(DIARFGL,":")="SPECIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q
 I +$P(DIARFGL,U,2)=".01" S DIARA(".01")=$P(DIARFGL,"=",2) S DIARFGEN=1 Q
 Q
 ;
FG3 Q:+$P(DIARFGL,U,2)=DIARFN
 S DIARF2=+$P(DIARFGL,U,2),DIARZ=DIARZ+1
 F DIARZ=DIARZ:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:(($P(DIARFGL,":")="END")&(+$P(DIARFGL,U,2)=DIARF2))
 Q
 ;
IDS F DIARIDS=0:0 S DIARIDS=$O(DIARID(DIARIDS)) Q:DIARIDS'>0  I '$D(DIARA("ID",DIARIDS)) S DIARA("ID",DIARIDS)=""
 Q
 ;
MS S DIARMTID="",DIARMT01=0,DIARMTCH=0,DIARIDDN=0,DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY),1:0) Q
 ;
MATCH F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0  D MS D:$D(DIARR(DIARY,".01")) MATCH01 D:$D(DIARR(DIARY,"ID")) MATCHID:'DIARIDDN D:DIARMTCH FOUND
 Q
 ;
MATCH01 Q:DIARR(DIARY,".01")=""  Q:DIARA(".01")=""
 I $P(DIARA(".01"),DIARR(DIARY,.01))="" S DIARMT01=1
 I $D(DIARR(DIARY,"ID")) D MATCHID I 'DIARMTID Q
 I DIARMT01 S DIARMTCH=1
 Q
 ;
MATCHID F DIARZID=0:0 S DIARZID=$O(DIARR(DIARY,"ID",DIARZID))  Q:DIARZID'>0  D MATCHID1 Q:DIARMTID=0
 I DIARMTID,'$D(DIARR(DIARY,".01")) S DIARMTCH=1
 S DIARIDDN=1
 Q
 ;
MATCHID1 Q:DIARR(DIARY,"ID",DIARZID)=""  Q:DIARA("ID",DIARZID)=""
 I $P(DIARA("ID",DIARZID),DIARR(DIARY,"ID",DIARZID))="" S DIARMTID=1 Q
 S DIARMTID=0
 Q
 ;
FOUND S DIARFND=1
 I $D(DIARIDX) S DIARIXX(DIARIXCT)=DIARIXX(DIARIXCT)_DIARY_"," Q
 S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)+1," D %XY^%RCR
 S DIARRF(DIARY)=DIARRF(DIARY)+1
 Q
 ;
EOP S DIARZ=0,DIARFGEN=0
 K ^TMP("DIARFG",$J),DIARA
 Q

DIARR3
DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93  7:55 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIARFND  U IO(0) W !,"Formatting found records..."
 S (DIARTAB,DIAROREQ,DIAROM,DIAROZ,DIARZZ,DIAROIDF,DIAROFLD,DIAROLVL,DIAROBPT,DIAROBFN)=0,DIAROFLD(DIAROLVL)=0 K ^TMP("DIARO",$J)
 F  S DIAROREQ=$O(^TMP("DIAR",$J,DIAROREQ)) Q:DIAROREQ'>0  F  S DIAROM=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM)) Q:DIAROM'>0  D CLEANUP^DIARR4 F  S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)) Q:DIAROZ'>0  S DIAROX=^(DIAROZ) D EN
 Q
EN Q:DIAROX["$END DAT"!(DIAROX="")
 S DIAROX1=$P(DIAROX,":")
 I $P(DIAROX,U)="$DAT" S DIAROSF=$P(DIAROX,U,2),DIAROSFN=+$P(DIAROX,U,3),DIAROLNE="ARCHIVE FILE: "_DIAROSF_" (#"_DIAROSFN_")" D SET D SV Q
 Q:DIAROX["$END DAT"
EN1 I DIAROX1="BEGIN" D BEGIN D SV Q
 I DIAROX1="END" D END D SV Q
 I DIAROX1="IDENTIFIER"!(DIAROX1="SPECIFIER")!(DIAROX1="KEY") D ID D SV Q
 I $L(DIAROX,U)=3,"AMLD"[$P($P(DIAROX,U,3),"=") G:$P(DIAROX,"=",2)?1"@".N1"E" BE^DIARR4 D F1 I DIAROSFN=+$P(DIAROX,U,2) D SV Q
 I DIAROX="^"!(DIAROX=":") D POP^DIARR4 D SV Q
 I $E(DIAROX1)="""" S DIAROLNE=$E(DIAROX1,2,$L(DIAROX1)-1) D SET Q
 D FLDS
SV S DIAROXPL=DIAROX
 Q
BEGIN S DIAROBF=$P($P(DIAROX,U),":",2),DIAROBFN=+$P(DIAROX,U,2),DIARTAB=DIARTAB+2,DIAROLVL=DIAROLVL+1,DIAROSTK(DIAROLVL)=DIAROBF_U_DIAROBFN_U_DIARTAB,DIAROIDF(DIAROLVL)=0,DIAROFLD(DIAROLVL)=0
 S DIAROSUB="@"_$P(DIAROX,"@",2),DIAROAT(DIAROSUB)=$S(DIAROXPL["@":"@"_$P(DIAROXPL,"@",2),1:$P(DIAROXPL,"=",2)) I DIAROBPT D SUB Q
 I DIAROZ=3 G BEGLN1
 I $P(DIAROXPL,U,2)[":" S DIAROLNE="FILE: " D SUB G BEGLN
 I $P(DIAROXPL,":")="BEGIN" S DIAROLNE=".01 POINTER TO FILE: " G BEGLN
 I $L(DIAROXPL,U)=3,"AMLD"[$P($P(DIAROXPL,U,3),"=") S DIAROLNE="SUBFILE: " D SUB G BEGLN
 I $L(DIAROXPL,U)=2 S DIAROLNE="POINTER TO FILE: "
BEGLN S DIAROLNE=DIAROLNE_DIAROBF_" (#"_DIAROBFN_")"
 D SET
BEGLN1 I $D(DIAROLUP(DIAROBF)) S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3),DIAROLNE=$P(DIAROLUP(DIAROBF),U) D SET K DIAROLUP(DIAROBF)
 Q
SUB S DIAROSUB(DIAROBFN)=1_U_DIARTAB
 Q
END S (DIAROIDF(DIAROLVL),DIAROFLD(DIAROLVL))=0,DIAROBF=$P(DIAROSTK(DIAROLVL),U),DIAROBFN=$P(DIAROSTK(DIAROLVL),U,2)
 I $D(DIAROSUB(DIAROBFN)) S DIARTAB=DIARTAB-2 Q
 S:DIAROLVL'=1 DIAROLVL=DIAROLVL-1
 Q
ID I DIAROIDF(DIAROLVL)=0 S DIAROLNE="IDENTIFIERS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROIDF(DIAROLVL)=1
 S DIAROLNE=$P($P(DIAROX,U),":",2)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX,"=",2),DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+4 D SET
 Q
FLDS S DIAROBCK=0
 I DIAROLVL=1,DIAROFLD(DIAROLVL)=0 S DIAROLNE="FIELDS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROFLD(DIAROLVL)=1
 S (DIAROVAL,DIAROLUP)=$P(DIAROX,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+4
 I $L(DIAROX,U)=3 S DIAROBF1=$P(DIAROX,U,2) I $E(DIAROBF1,$L(DIAROBF1))=":" D BKPTR^DIARR4 Q
 I +$P(DIAROX,U,2),DIAROVAL["" S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = " D LKUP^DIARR4:$E(DIAROVAL)="@" G:DIAROBCK FLDS
 I $D(DIAROSUB)=11 S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2
 S DIAROLNE=DIAROLNE_DIAROVAL D SET Q
 S:$D(DIAROXX) DIAROX=DIAROXX K DIAROXX
 Q
SET S DIAROTAB="" S:DIARTAB $P(DIAROTAB," ",DIARTAB)=" "
 S DIARZZ=DIARZZ+1,DIAROLNE=DIAROTAB_DIAROLNE
 S ^TMP("DIARO",$J,DIAROREQ,DIAROM,DIARZZ)=DIAROLNE
 Q
F1 S DIAROLUP($P(DIAROX,U))="LOOKUP VALUE (#.01): "_$P(DIAROX,"=",2)
 Q

DIARR4
DIARR4 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG(CONT) ;3/15/93  8:54 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CLEANUP K DIAROSF,DIAROSFN,DIAROBF,DIAROBFN,DIAROFLD,DIAROIDF,DIAROSUB,DIAROLUP
 S (DIARTAB,DIAROIDF,DIAROFLD,DIAROLVL)=0
 Q
 ;
LKUP Q:$E(DIAROVAL)'="@"
 S DIAROVAL=$G(DIAROAT(DIAROVAL)) I $E(DIAROVAL)="@" G LKUP
 S DIAROXX=DIAROX,DIAROX=$P(DIAROX,"=")_"="_DIAROVAL,DIAROBCK=1
 Q
 ;
BKPTR S DIAROLNE="FILE SHIFT (Forward Pointer/Backward Pointer): " D SET^DIARR3
 I DIAROX["=@",$G(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ+1))'["BEGIN:" S DIAROLNE="FILE: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_")" D SET^DIARR3 D SFT2
 Q
 ;
SFT2 S DIAROBPT=1,DIAROXX=DIAROX,DIAROX="BEGIN:"_$P(DIAROX,":")_$P(DIAROX,"=",2)
 D BEGIN^DIARR3
 S DIAROBPT=0
 S DIAROX=DIAROXX K DIAROXX
 Q
 ;
POP S DIAROLVL=DIAROLVL-1 S:DIAROLVL=0 DIAROLVL=1
 K DIAROSUB(DIAROBFN)
 Q
 ;
BE S DIAROLVL=+$P($P(DIAROX,"=",2),"@",2)
 I $P(DIAROX,U)=$P(DIAROSTK(DIAROLVL-1),U) S DIAROSTK(DIAROLVL)=DIAROSTK(DIAROLVL-1)
 S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)),DIAROX2=^(DIAROZ)
 S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX2,"=",2) D SET^DIARR3
 S DIAROLNE="SUBFILE: "_$P(DIAROX,U)_" (#"_$P(DIAROSTK(DIAROLVL),U,2)_") ",DIARTAB=$P(DIAROSTK(DIAROLVL),U,3) D SET^DIARR3
 S DIAROLNE="LOOKUP VALUE (#.01): "_$P(DIAROX2,"=",2) D SET^DIARR3
 S DIAROLNE="FIELD NAME: "_$P(DIAROX2,U)_" (#"_+$P(DIAROX2,U,2)_") = "_$P(DIAROX2,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2 D SET^DIARR3 S DIARTAB=DIARTAB-4
 Q

DIARR5
DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93  8:00 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PRINT I $D(DIARQUED) G Q
 S IOP=DIARPDEV D ^%ZIS G Q:POP
DQ S DIARPG=0
 F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0  D HD Q:$D(DTOUT)!($D(DIRUT))  D PRINT1:$D(^TMP("DIARO",$J,DIARY)) W:'$D(^TMP("DIARO",$J,DIARY)) !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
 D ^%ZISC
 Q
 ;
PRINT1 F DIARZ=0:0 S DIARZ=$O(^TMP("DIARO",$J,DIARY,DIARZ)) Q:DIARZ'>0!$D(DTOUT)!$D(DIRUT)  W ! F DIARZ1=0:0 S DIARZ1=$O(^TMP("DIARO",$J,DIARY,DIARZ,DIARZ1)) Q:DIARZ1'>0  W ^(DIARZ1),! I $Y>(IOSL-2) D HD Q:$D(DTOUT)!$D(DIRUT)
 W !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
 Q
 ;
HD U IO
 I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT))
 S Y=DT X ^DD("DD")
 W:$Y @IOF W "ARCHIVE RETRIEVAL LIST",?60,Y,?72,"PAGE: ",DIARPG+1
HD1 W !,"REQUEST: ",DIARY W:$D(DIARR(DIARY,.01)) !,?2,DIAR01," = ",DIARR(DIARY,.01) D HD2:$D(DIARR(DIARY,"ID"))
 S $P(DIARLINE,"-",IOM)="" W !,DIARLINE,! S DIARPG=DIARPG+1
 Q
 ;
HD2 F DIARX1=0:0 S DIARX1=$O(DIARR(DIARY,"ID",DIARX1)) Q:DIARX1'>0  W:DIARX1 !,?2,$P(DIARID(DIARX1),U)," = ",DIARR(DIARY,"ID",DIARX1)
 Q
 ;
Q S ZTRTN="DQ^DIARR5",ZTDTH=$H,ZTSAVE("DIARR(")="",ZTSAVE("^TMP(""DIARO"",$J,")="",ZTSAVE("DIARRF(")="",ZTDESC="RETRIEVAL OF ARCHIVED DATA",ZTIO=DIARPDEV,ZTSAVE("DIAR01")="",ZTSAVE("DIARID(")=""
 D ^%ZTLOAD,HOME^%ZIS
 U IO(0) W !! I '$D(DIARQUED) W:POP "UNABLE TO OPEN SELECTED PRINTER AT THIS TIME.  "
 W "OUTPUT QUEUED!"
 Q

DIARR6
DIARR6 ;SFISC/DCM-PROCESS ARCHIVED FILE WITH INDEX ;11/18/92  11:49 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIARFILE=$P(DIARL,U,3),DIARFN=+$P(DIARL,U,2)
 S DIARREC=$P(DIARL,U,4,99)
 F DIARXX=1:1 S DIARFLD=$P(DIARREC,U,DIARXX) Q:DIARFLD=""  S DIARFNO=$P(DIARFLD,":"),DIARFNA=$P(DIARFLD,":",2) D
 . I +DIARFNO=.01 S DIAR01=DIARFNA
 . S DIARPC(DIARXX)=DIARFNO_U_DIARFNA
 . S:+DIARFNO'=.01 DIARID(DIARFNO)=DIARFNA_U_DIARFNO
 . S DIARCNT=DIARXX
 . Q
 S DIARCTR=0,DIARFLGT=0
 F  X DIARX Q:DIARL["$DAT"  S DIARCTR=DIARCTR+1 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARL,U,DIARXX) S DIARFNA=$P(DIARPC(DIARXX),U,2),DIARFNO=+DIARPC(DIARXX),^TMP("DIARHLP",$J,DIARCTR,DIARFNO)=DIARFNA_" = "_DIARFLD D FLGTH
 Q
 ;
FLGTH S $P(DIARPC(DIARXX),U,3)=$S($L(DIARFLD)>+$P(DIARPC(DIARXX),U,3):$L(DIARFLD),1:+$P(DIARPC(DIARXX),U,3))
 Q
 ;
PROC S DIARIXCT=0 K DIARRF
PROC1 F  X DIARX Q:DIARL["$DAT"  G PROC1:DIARL["$INDEX" D PROC2 D MATCH^DIARR2 K:'$G(DIARIXX(DIARIXCT)) DIARIXX(DIARIXCT) G PROC1
 Q:'$D(DIARIXX)
 S (DIARIXCT,DIARXX)=1 D:$G(DIARIXX(DIARIXCT)) FOUND
 F  S DIARXX=$O(DIARIXX(DIARXX)) Q:DIARXX'>0  D PROC1A
 Q
 ;
PROC1A F  X DIARX Q:DIARL["#$#"  I DIARL["$DAT" S DIARIXCT=DIARIXCT+1 I DIARIXCT=DIARXX D FOUND Q
 Q
 ;
PROC2 K DIARA S DIARIXCT=DIARIXCT+1,DIARIXX(DIARIXCT)=""
 F DIARXX=1:1:DIARCNT S DIARVAL=$P(DIARL,U,DIARXX) D PROC2A
 Q
 ;
PROC2A I +$P(DIARPC(DIARXX),U)=.01 S DIARA(.01)=DIARVAL Q
 S DIARA("ID",+$P(DIARPC(DIARXX),U))=DIARVAL
 Q
 ;
FOUND K ^TMP("DIARFG",$J) S DIARZ=1 D SET
 F DIARZ=DIARZ+1:1 X DIARX D SET I DIARL["$END DAT" Q
 F DIARZ=1:1 S DIARY=$P(DIARIXX(DIARIXCT),",",DIARZ) Q:DIARY=""  S DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY)+1,1:0) D SETFG
 Q
 ;
SET S ^TMP("DIARFG",$J,DIARZ)=DIARL
 Q
 ;
SETFG S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)," D %XY^%RCR
 Q

DIARU
DIARU ;SFISC/TKW-ARCHIVING FUNCTIONS (CONT) ;2/18/93  5:21 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
UPDATE ;UPDATE ARCHIVING FILE (DJ=#ITEMS SELECTED) called w/in DIO4
 N DIE D:DIAR=3 NOW^%DTC S DA=DIARC,DIE="^DIAR(1.11,",X=""
 S:DIAR&(DIAR'=3) X="7////"_DIAR_";"
 S X=X_"13////@;14////@;15////@"
 I DIAR=1 S X=X_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";6////"_DJ
 I DIAR=3 S X=X_";12////"_%
 I DIAR=4!(DIAR=5)!(DIAR=6) S X=X_$S($D(^VA(200)):";5////"_DUZ,1:"")_";10////"_DT
 ;I DIAR=3!(DIAR=4),U'[DIARP S %=$P(DIARP,U,2),X=X_";3////"_$S(%:%,1:+DIARP)
 I DIAR=90 S X=X_$S($D(^VA(200)):";9////"_DUZ,1:"")_";11////"_DT
 S DR=X,DA=DIARC D ^DIE S DV=""
 Q
 ;
FILE ;LOOKUP ARCHIVING ACTIVITY
 K DIC S DIC(0)="AEQIMZ",DIC="^DIAR(1.11,",DIC("S")="I $P(^(0),U,8)<90"_$S($D(DIAX):",$P(^(0),U,17)",1:",'+$P(^(0),U,17)"),DIC("A")="Select "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" ACTIVITY: "
 D ^DIC Q:Y<0!$D(DUOUT)!$D(DTOUT)
 I $P(Y(0),U,14) D ER1 Q
 S DIARC=+Y,DIARF=$P(Y(0),U,2),DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4),DIARST=$P(Y(0),U,8) S:$D(DIAX) DIAXFNO=+$P(Y(0),U,18)
 I DIAR'=99,'DIARU W !!,$C(7),"No selection template used for this ARCHIVING ACTIVITY--CANCEL it!" K DIARC Q
 I (DIAR=2!(DIAR=4)),DIARST>2 D ER2 K DIARC Q
 I DIAR=5 W:DIARST=5 $C(7),!!,"This data has already been moved to permanent storage once !!",! I DIARST<4 D ER3 K DIARC Q
 I DIAR=6,DIARST=6 W !!,$C(7),"This data has already been moved to the destination file!",!,"PURGE data or CANCEL this extract activity." K DIARC Q
 I DIAR=90,$S($D(DIAX):DIARST'=6,1:DIARST'=5) D ER4 K DIARC Q
 I DIAR=99 D:DIARST=5 MSG I DIARST>6 D ER5 K DIARC Q
 S DIARF2=$S($D(^DIAR(1.11,+Y,1)):^(1),1:DIARF)
 S DIARX=Y(0) D:DIAR'=3 MRK S Y(0)=DIARX,DIC=$G(^DIC(+DIARF,0,"GL")) I DIC="" D ER6 S DIK="^DIAR(1.11,",DA=DIARC D ^DIK K DIK,DIARC Q
 Q
 ;
MRK ;SET FIELDS TO LOCK OUT OTHER USERS DURING ARCHIVING ACTIVITY
 D NOW^%DTC S DIE="^DIAR(1.11,",DA=DIARC,DR="13////"_DIAR_";14////"_%_";15////"_DUZ D ^DIE
 Q
 ;
ER1 W $C(7),!!!,"The following Archival Activity is in progress--no access allowed!",!
 S DIARX=Y(0),Y=$P(Y(0),U,14),C=$P(^DD(1.11,13,0),U,2) D Y^DIQ W Y_"     STARTED: " S Y=$P(DIARX,U,15) X:Y ^DD("DD") W Y_"    BY: " W:$S($D(^VA(200,+$P(DIARX,U,16),0)):1,1:$D(^DIC(3,+$P(DIARX,U,16),0))) $P(^(0),U,1) W ! Q
ER2 I $D(DIAX) W !!,$C(7),"Data has already been moved to the destination file.",!,"List cannot be edited." Q
 W !!,$C(7),"This data has already been archived to "_$S(DIARST=4:"temporary",1:"permanent")_" storage" W:DIARST>5 " and purged" W ".",! W:DIAR=2 "List cannot be edited after data has been archived!" Q
ER3 W !!,$C(7),"Cannot write to permanent storage until data has been written",!,"to temporary storage!!" Q
ER4 W !!,$C(7),$S(DIARST>6:"Data ALREADY purged",$D(DIAX):"Data has NOT YET been moved to the destination file",1:"Data has NOT YET been archived to PERMANENT storage"),"!",! Q
ER5 W !!,$C(7),"Cannot cancel archiving record after archiving has been complete--this now",!,"acts as your history!!" Q
ER6 W !!,$C(7),"Source File is missing!",!,"I AM DELETING THIS ",$S($D(DIAX):"EXTRACT",1:"ARCHIVING")," ACTIVITY!" Q
MSG W !!,$C(7),"Just a reminder--you have already archived these records to permanent storage.",!,"You probably won't want to save the sequential storage media since you",!,"are cancelling this archiving activity!!",! Q

DIARX
DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;4/8/93  8:01 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
IX K ^UTILITY("DIQ1",$J) N DIC
 S DIARREC=^DIAR(1.11,DIARC,0),(DIARIXF,DIC)=$P(DIARREC,U,2),DIARIXST=$P(DIARREC,U,3),(DA,DIARDR,DIARIX,DIARDA)="",DR=".01",DIARLINE=.01_":"_$P(^DD(DIARIXF,.01,0),U)
 F  S DIARDR=$O(^DD(DIARIXF,0,"ID",DIARDR)) Q:DIARDR'>0  I $D(^DD(DIARIXF,DIARDR,0)) S DIARLINE=DIARLINE_U_DIARDR_":"_$P(^(0),U),DR=DR_";"_DIARDR
 S DIARBLNE=DIARLINE,DIARLINE="$INDEX"_U_DIARIXF_U_$P(^DIC(DIARIXF,0),U)_U_DIARLINE U IO W DIARLINE,!
 F  S DA=$O(^DIBT(DIARIXST,1,DA)) Q:DA'>0  S DIQ(0)="E" D EN^DIQ1
 F  S DIARDA=$O(^DIBT(DIARIXST,1,DIARDA)) Q:DIARDA'>0  D IX1
 K DIARREC,DIARIXF,DIARIXST,DA,DIARDR,DIARIX,DIARDA,DR,DIARLINE
 Q
 ;
IX1 S DIARLINE="" F  S DIARIX=$O(^UTILITY("DIQ1",$J,DIARIXF,DIARDA,DIARIX)) Q:DIARIX'>0  S DIARLINE=DIARLINE_^(DIARIX,"E")_U
 W DIARLINE,!
 Q
 ;
OUT I $D(DIARQUED) G QP
 S IOP=DIARPDEV D ^%ZIS G QP:POP
DQ ;print archive activity report
 S DIARPG=0,DIARLINE="",DIARX=^DIAR(1.11,DIARC,0),DIARFI=$P(DIARX,U,2) U IO S Y=DT X ^DD("DD") S DIARXY=Y
 D HDR,BODY
 Q
HDR W:$Y @IOF W !,"ARCHIVE ACTIVITY REPORT",?IOM-24,DIARXY,?IOM-10,"PAGE: ",DIARPG+1
 S DIARPG=DIARPG+1,$P(DIARLINE,"-",IOM)="" W !,DIARLINE Q
 ;
BODY W !!,"ARCHIVAL ACTIVITY: ",DIARC,!,"ARCHIVE DEVICE LABEL INFORMATION: ",$P(^DIAR(1.11,DIARC,0),U,19)
 W !,"PRIMARY ARCHIVED FILE: ",$P($G(^DIC(DIARFI,0)),U)_" (#"_DIARFI_")"
 W !,"ARCHIVER: ",$P($G(^VA(200,$P(DIARX,U,6),0)),U)
 W !,"SEARCH CRITERIA: " S DIARU=$P(DIARX,U,3),DIARXZ=0
 F  S DIARXZ=$O(^DIBT(DIARU,"O",DIARXZ)) Q:DIARXZ'>0  Q:'$D(^(DIARXZ,0))  W !,?5,^(0)
 W !!,"INDEX INFORMATION: ",! S (DIARTAB,DIARFLD)=0 F DIARXZ=1:1 S DIARFLD=$P($P(DIARBLNE,U,DIARXZ),":",2) Q:DIARFLD=""  W DIARFLD S DIARTAB=DIARTAB+25 W ?DIARTAB
 F DIARXZ=0:0 S DIARXZ=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ)) Q:DIARXZ'>0  D HDRC Q:$D(DTOUT)!$D(DIRUT)  W ! S DIARTAB=0 F  S DIARFLD=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ,DIARFLD)) Q:DIARFLD'>0  W ^(DIARFLD,"E") S DIARTAB=DIARTAB+25 W ?DIARTAB
 W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
 I $E(IOST)'="C",$Y W @IOF
 D ^%ZISC
 Q
 ;
HDRC Q:($Y+1<IOSL)
 I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT))
 D HDR
 Q
 ;
QP S ZTRTN="DQ^DIARX",ZTSAVE("DIARC")="",ZTDESC="ARCHIVE ACTIVITY REPORT",ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("DIARBLNE")="",ZTIO=DIARPDEV,ZTDTH=$H
 D ^%ZTLOAD,HOME^%ZIS

DIAU
DIAU ;SFISC/XAK-AUDIT OPTIONS ;7/29/94  10:48
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DIAU"","
 G OPT:$D(^DOPT("DIAU",5)) S ^(0)="AUDIT OPTION^1.01" K ^("B")
 F X=1:1:5 S ^DOPT("DIAU",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK
OPT ;
 S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
EN ;
 D @DI W !!
Q K %,DIC,DIK,DI,DA,I,J,X,Y Q
 ;
1 ;;FIELDS BEING AUDITED
 D L^DICRW1 Q:'$D(DIC)  S (DUB,DIB,DFF)=+Y,BY(0)="^DD(DFF,""AUDIT"",",L(0)=1
 I $O(^DD(DIB,"AUDIT",""))="" F  S DIB=$O(^DIC(+DIB)) Q:'DIB!(DIB>DIB(1))  I $O(^DD(DIB,"AUDIT",""))]"" S (DUB,DFF)=DIB Q
 I 'DIB!(DIB>DIB(1)) G Q2
 S FLDS="W DFF;C1;L9;""FILE"",.001;L9,.01;L20,.25;L15,1.1",DISUPNO=1
 S L=0,DHD="AUDITED FIELDS",DIS(0)="I $D(^DD(DFF,D0,""AUDIT"")),""n""'[^(""AUDIT"")"
 S DIA=1,DIC="^DD(DFF,",DIOEND="G L^DIDC" D EN1^DIP
 G Q2
 ;
2 ;;DATA DICTIONARIES BEING AUDITED
 S DIC=1,BY=.001,FLDS=".001;L14;""FILE"",.01",L=0
 S DIS(0)="I $D(^DD(D0,0,""DDA"")),^(""DDA"")[""Y"""
 S DHD="DATA DICTIONARIES BEING AUDITED" D EN1^DIP
Q2 K DIA,A,B,DIJ,DP,P,FLDS,DIS,DHD,DCC,L,DNP,DFF,DIB,DIJS,DIPQ,DIMS,DIPP,DUB,DIOEND Q
 ;
3 ;;PURGE DATA AUDITS
 S DIC("S")="I $D(^DIA(+Y)) S DIAC=""AUDIT"",DIFILE=+Y D ^DIAC I DIAC"
 S DIA="" D AU^DICRW K DIC("S") G Q2:$D(DTOUT),Q2:Y<0,Q2:'$D(DIC)
 S DDA="DATA" D ALL G Q2:$D(DIRUT)
 I Y K ^DIA(DIA) H 3 W !!,"DELETED" G Q2
 W ! S L="PURGE AUDIT RECORDS",DIOEND="W !!,DIACNT,"" RECORDS PURGED.""",DISTOP=0
 S FLDS="",DHD="PURGE OF AUDIT DATA: "_$O(^DD(DIA,0,"NM",0))_" FILE",DISUPNO=1
 S DHIT="S DIK=DCC,DA=D0,DIACNT=DIACNT+1 D ^DIK",DIACNT=0
 D EN1^DIP K DISTOP,DHIT,DIK,DA,DIACNT G Q2
 ;
4 ;;PURGE DD AUDITS
 S DIC("S")="I $D(^DDA(+Y)) S DIAC=""AUDIT"",DIFILE=+Y D ^DIAC I DIAC"
 S DIA="DDA",DDA="DD" D A^DICRW G Q:$D(DTOUT)!(Y<0)!'$D(DIC)
 D ALL G:$D(DIRUT) Q I Y S X=DIA D PR G Q
 W ! S L="PURGE DD AUDIT RECORDS",DIOEND="G M^DIAU",DISTOP=0,DISUPNO=1
 S FLDS="",DHD="PURGE OF DD AUDIT: "_$O(^DD(DIA,0,"NM",0))_" FILE"
 S DHIT="S DIK=DCC,DA=D0,DIACNT=DIACNT+1 D ^DIK",DIACNT=0,DIC="^DDA(DDA,"
 S DDA=DIA D EN1^DIP K DISTOP,DHIT,DIK,DA,DIACNT G Q2
 ;
5 ;;TURN DATA AUDIT ON/OFF
 S (DDA,DIA)=0 D AU^DICRW K DDA
 I 'DIA K DIA,DUOUT Q
51 S DIC="^DD("_DIA_",",DIC(0)="QEANIZ",DA(1)=DIA
 S DIC("S")="I 1 S %=$P(^(0),U,2) Q:'%&($E(%)'=""C"")  I $E(%)'=""C"",$P(^DD(+%,.01,0),U,2)'[""W"""
52 S DIC("W")="W:$P(^(0),U,2) ""  (multiple)"""
 D ^DIC I Y<0 K DIA G Q
 I $P(Y(0),U,2) S DA(1)=+$P(Y(0),U,2),DIC="^DD("_DA(1)_"," G 52
 S DA=+Y,DIE=DIC,DR=1.1 K DIC D ^DIE
 W ! K C,D,DQ,DR,D0,DIE G Q:$D(Y),51
 ;
ALL S DIR(0)="Y",DIR("B")="NO"
 S DIR("A")="DO YOU WANT TO PURGE ALL "_DDA_" AUDIT RECORDS"
 S DIR("??")="^W !!?5,""Answer 'YES' to purge all the "_DDA_" audit records for this file, or"",!?5,""answer 'NO' to sort out the records to be purged."""
 D ^DIR Q:$D(DIRUT)  I Y S DIR("A")="ARE YOU SURE" D ^DIR
 K DIR Q
PR N DIA S DIA=X N X K ^DDA(DIA)
 F X=0:0 S X=$O(^DD(DIA,"SB",X)) Q:X'>0  D PR
 Q
M S DDA=$O(^DDA(DDA))
 I DDA'>0!(DDA-1>DIA) W !!,DIACNT," RECORDS PURGED." G QM
 S %=0,X=DDA D UP G P:%,M:'%
UP Q:'$D(^DD(X,0,"UP"))  S X=^("UP") I X=DIA S %=1 Q
 G UP
P K ^UTILITY($J,0) S %X="DIPP(",%Y="DPP(" D %XY^%RCR
 S DPP=DIPP,L=0,DJ=DIJS,DPQ=DIPQ,M=DIMS,C=",",DIOSL=IOSL G ^DIO
 Q
QM ;RETURN TO ^DIO4 FROM LINE TAG M
 G STOP^DIO4

DIAX
DIAX ;SFISC/DCM-EXTRACT OPTIONS ;5/13/96  13:52
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIK="^DOPT(""DIAX""," G OPT:$D(^DOPT("DIAX",9))
 S ^(0)="EXTRACT OPTION^1.01^" K ^("B")
 F I=1:1:9 S ^DOPT("DIAX",I,0)=$P($T(@I),";;",2)
 D IXALL^DIK
OPT W ! S DIC=DIK,DIC(0)="AEQIZ" D ^DIC K DIC,DIK
 I Y'<0 S DI=+Y K Y D EN G 0
 W ! K %,DIC,DIK,DI,DA,I,J,X,Y,DIAX Q
 ;
EN S DIAX=1
 D @DI
 Q
 ;
1 ;;SELECT ENTRIES TO EXTRACT
 G 1^DIAR
 ;
2 ;;ADD/DELETE SELECTED ENTRIES
 S DIAR=2 G ENTE^DIARB
 ;
3 ;;PRINT SELECTED ENTRIES
 S DIAR=3 G OUT^DIARA
 ;
5 ;;CREATE EXTRACT TEMPLATE
 W !!,"This option lets you build a template where you specify fields to extract",!,"and their corresponding mapping in the destination file."
 W !!,"For more detailed description of requirements on the destination file,",!,"please see your VA FileMan User Manual."
 S DI=1 G EN^DIFGO
 ;
4 ;;MODIFY DESTINATION FILE
 W !!,"This option allows you to build a file which will store data extracted from",!,"other files.  When creating fields in the destination file, all data types"
 W !,"are selectable.  However, only a few data types are acceptable for receiving",!,"extracted data."
 W !!,"Please see your User Manual for more guidance on building the destination file."
 D 41 G Q:'$D(DIAXDIC)
 D 61,Q
 Q
41 ;
 G ^DICATT
61 ;
 Q:$P(@(^DIC(DIAXDIC,0,"GL")_"0)"),U,4)
 K DIR S DIR("A")="ARCHIVE FILE",DIR(0)="YO",DIR("??")="^W !?5,""'YES' will not allow modifications or deletions of data or data dictionary"",!?5,""'NO'  will place no restrictions on the file"""
 S DIR("B")=$S($P($G(^DD(DIAXDIC,0,"DI")),U)["Y":"YES",1:"NO")
 D ^DIR Q:$D(DTOUT)!$D(DUOUT)  S (DIARCH,DIE)=$S(Y:"Y",1:"N")
62 ;
 D FLAG(DIAXDIC,DIE,DIARCH)
 K DIAXDIC,DIE,DIARCH
 Q
H6 W !!?5,"'YES' will not allow editing or deleting existing file entries or adding",!?11,"new file entries"
 W !?5,"'NO'  will place no restrictions on the file"
 Q
6 ;;UPDATE DESTINATION FILE
 N DIAR,DIARC,DIARP,DIARB,DIE,DA,DR,DTOUT,DIAXFNO,%ZIS,POP,ZTRTN,ZTSAVE
 S DIAR=6 D FILE^DIARU G Q:'$D(DIARC)
 N DIARP,DIE,DA,DR
 W !!,"You MUST enter an EXTRACT template name.  This EXTRACT template will be used",!,"to populate your destination file."
 S DIE="^DIAR(1.11,",DA=DIARC,DR="3;I X=""^"" S Y="";S DIARP=X;S DIAXFNO=+$P(^DIPT(DIARP,0),U,9);17////^S X=DIAXFNO" D ^DIE G UNLK:$D(DTOUT)!'$D(DIARP)
 S DIARB=+$P(^DIAR(1.11,DIARC,0),U,3)
 D EN^DIAXM I $G(DIERR) G UNLK
 W $C(7),!,"If entries cannot be moved to the destination file, an exception report",!,"will be printed.",!!,"Select a device where to print the exception report."
 W !!,"QUEUEING to this device will queue the Update process."
 N %ZIS,POP,ZTRTN,ZTSAVE,DIAXIOP
 S %ZIS="Q",%ZIS("A")="EXCEPTION REPORT DEVICE: ",%ZIS("B")="" D ^%ZIS G UNLK:POP S DIAXIOP=ION
 I $D(IO("Q")) S ZTRTN="DQ^DIAXU",(ZTSAVE("DIARP"),ZTSAVE("DIARB"),ZTSAVE("DIARC"))="",ZTSAVE("DIAXIOP")="",ZTIO="" D ^%ZTLOAD G UNLK
 D DIAX^DIAXU
 Q
 ;
7 ;;PURGE EXTRACTED ENTRIES
 S DIAR=90 G ENTD^DIARA
 ;
8 ;;CANCEL EXTRACT SELECTION
 S DIAR=99 G ENTC^DIARA
 ;
9 ;;VALIDATE EXTRACT TEMPLATE
 N X,DIC,Y
 S DIC="^DIPT(",DIC(0)="ASQEM",DIC("A")="Select EXTRACT TEMPLATE: ",DIC("S")="I $P(^(0),U,8)=2"
 D ^DIC Q:Y'>0
 S DIARP=+Y,DIAR=""
 D EN^DIAXM
 D Q G 9
 ;
UNLK N DIAR S DIAR=""
 D UPDATE^DIARU
Q D Q^DIARB
 Q
 ;
FLAG(DIC,DIE,DIARCH)  ;
 Q:'DIC  Q:'$D(^DD(DIC,0))
 S $P(^DD(DIC,0,"DI"),U)=DIARCH,$P(^DD(DIC,0,"DI"),U,2)=DIE
 Q

DIAXD
DIAXD ;SFISC/DCM-GET SOURCE DATA ;9/6/96  15:17
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N DILL,FRFILE,TOFILE,DIAXIEN,DIAXI,DIAXFR,DIAXTO,DATAFR,DATALST,Z
 S (DILL,DIAXI)=$G(DILL)+1,FRFILE=@DIAXTFR@(DILL,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),Z=","
 S DIAXFR="^TMP($J,""DIAXFR"")",DIAXTO="^TMP($J,""DIAXTO"")",DATAFR="^TMP($J,""DATAFR"")",DATALST="^TMP($J,""DATALST"")"
 D Q,TOP I $G(DIERR) D Q Q
 D NEXTLVL
Q K @DIAXFR,@DIAXTO,@DATAFR
 K:$G(DIERR) ^TMP("DIAX",$J)
 Q
TOP ;
 N FRIENS,TOIENS
 S (FRIENS,@DIAXFR@(FRFILE,"IENS"))=DIAXFE_Z
 S (TOIENS,@DIAXTO@(TOFILE,"IENS"),@DIAXTO@(FRFILE,"IENS",FRIENS))=$$DIAXIEN()
 D GETFDA(FRIENS,TOIENS)
 Q
GETFDA(FRIENS,TOIENS) ;
 D GETS Q:$G(DIERR)
 D FDA
 Q
GETS ;
 N DR,FLAGS,FIELDS
 F  S DR=$G(DR)+1 Q:'$G(@DIAXTFR@(FRFILE,"DR",DR))  D  Q:$G(DIERR)
 . S FLAGS="EIN"
 . S FIELDS=@DIAXTFR@(FRFILE,"DR",DR)
 . D GETS^DIQ(FRFILE,FRIENS,FIELDS,FLAGS,DATAFR,DIAXERR) D:$G(DIERR) ERR
 Q
FDA ;
 N A,B,C S A=0
 F  S A=$O(@DATAFR@(FRFILE,FRIENS,A)) Q:A'>0  F C=0,1 S B=$G(@DIAXTTO@(FRFILE,A,C)) D:B]""  Q:$G(DIERR)
 . I $O(@DATAFR@(FRFILE,FRIENS,A,0)) S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=U_$P($$GET1^DIQ(FRFILE,FRIENS,A,"B"),U,2) Q
 . S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=$S(+$P(B,U,3):@DATAFR@(FRFILE,FRIENS,A,"E"),1:@DATAFR@(FRFILE,FRIENS,A,"I"))
 I '$D(^TMP("DIAX",$J,TOFILE,TOIENS,.01)) S ^TMP("DIAX",$J,TOFILE,TOIENS,.01)=$$GET1^DIQ(FRFILE,FRIENS,.01,"I","",DIAXERR) D:$G(DIERR) ERR
 K @DATAFR
 Q
GETLIST ;
 N SCR,A,B S SCR=$G(DIAXSCR(FRFILE))
 S FRIENS=$G(FRIENS),PART=$G(PART),INDEX=$G(INDEX) K @DATALST
 D LIST^DIC(FRFILE,FRIENS,"","","","",PART,INDEX,.SCR,"",DATALST,DIAXERR)
 I $G(DIERR) D ERR,Q1 Q
 I '$P(@DATALST@("DILIST",0),U) D Q1 Q
 I $G(PART)]"" S FRIENS=Z_@DIAXFR@(PARENT,"IENS")
 S A=0 F  S A=$O(@DATALST@("DILIST",2,A)) Q:A'>0  S B=@DATALST@("DILIST",2,A),@DIAXFR@(FRFILE,"IENS",$E(FRIENS,2,99),B_FRIENS)=""
Q1 K @DATALST,PART,INDEX
 Q
TOIENS ;
 N A,B S A=""
 F  S A=$O(@DIAXFR@(FRFILE,"IENS",FRIENS,A)) Q:A=""  S B=$$DIAXIEN(),@DIAXTO@(FRFILE,"IENS",A)=B_@DIAXTO@(PARENT,"IENS",FRIENS)
 Q
GETDATA ;
 Q:'$D(@DIAXTFR@(FRFILE,"DR"))
 N A,ZFRIENS S A="",ZFRIENS=FRIENS N FRIENS
 F  S A=$O(@DIAXFR@(FRFILE,"IENS",ZFRIENS,A)) Q:A=""  S FRIENS=A D  Q:$G(DIERR)
 . N TOIENS
 . S TOIENS=@DIAXTO@(FRFILE,"IENS",FRIENS)
 . D GETFDA(FRIENS,TOIENS) Q:$G(DIERR)
 . I $D(DIAXFILE(FRFILE)) D  Q
 . . N Y,DIERZ
 . . D RECURSE
 . . I $G(DIERZ) N DIERR,Y S Y("IEN")=DIAXFE D BLD^DIALOG(1300,"",.Y) D STE^DIAXU()
 Q
MULT(FRIENS) ;
 S FRIENS=Z_FRIENS
 D GETLIST Q:$G(DIERR)
 S FRIENS=$E(FRIENS,2,99)
 D TOIENS
 D GETDATA
 Q
ERR ;
 Q:'$D(FRFILE)!('$D(FRIENS))
 Q:'$D(DIAXFILE(FRFILE))
 D STE^DIAXU(FRFILE,FRIENS)
 Q
NEXTLVL ;
 F DIAXI=$G(DIAXI):0 S DIAXI=$O(@DIAXTFR@(DIAXI)) Q:'$D(@DIAXTFR@(+DIAXI,"FR"))  D NEXTLVL2 Q:$G(DIERR)!(DIAXI="")
 Q
NEXTLVL2 ;
 N FRFILE,TOFILE,PARENT,DILL,FRIENS,TOIENS,TAG
 S FRFILE=@DIAXTFR@(DIAXI,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),PARENT=^("PRT"),DILL=^("P2"),TAG=^("P4")
 D @TAG
 Q
3 ;
 I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR)
 I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D MULT(FRIENS) Q
 N A,B S (A,B)="" F  S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B=""  D
 . F  S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A=""  D  Q:$D(DIAXFILE(PARENT))
 . . S FRIENS=A D MULT(FRIENS) Q:$G(DIERR)
 Q
2 ;
 N PTRFLD,FRIENS,PTRIEN,A,B
 S PTRFLD=$P(@DIAXTFR@(FRFILE,"P5"),":")
 I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D 21 Q
 S (A,B)="" F  S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B=""  D  Q:$G(DIERR)!('PTRIEN)
 . F  S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A=""  D  Q:$G(DIERR)!'(PTRIEN)!($D(DIAXFILE(PARENT)))
 . . S FRIENS=A D 21
 Q
21 N TOIENS
 S PTRIEN=$$GET1^DIQ(PARENT,FRIENS,PTRFLD,"I","",DIAXERR) D:$G(DIERR)  Q:$G(DIERR)!('PTRIEN)
 . N FRFILE
 . S FRFILE=PARENT
 . D ERR
 S FRIENS=PTRIEN_Z
 S TOIENS=@DIAXTO@(PARENT,"IENS",A)
 D GETFDA(FRIENS,TOIENS)
 Q
4 ;
 N PART,INDEX,FRIENS
 S PART=$$GET1^DIQ(PARENT,@DIAXFR@(PARENT,"IENS"),.01,"I","",DIAXERR) D:$G(DIERR)  Q:PART']""!$G(DIERR)
 . N FRFILE,FRIENS
 . S FRFILE=PARENT
 . S FRIENS=@DIAXFR@(PARENT,"IENS")
 . D ERR
 S INDEX=@DIAXTFR@(FRFILE,"P7")
 I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR)
 S FRIENS="" D GETLIST Q:$G(DIERR)
 S FRIENS=@DIAXFR@(PARENT,"IENS")
 D TOIENS,GETDATA
 Q
DIAXIEN() ;
 S DIAXIEN=$G(DIAXIEN)+1
 Q "+"_DIAXIEN_Z
FILE ;
 Q:'$D(^TMP("DIAX",$J))
 N IEN S IEN="^TMP($J,""IEN"")"
 D Q2,UPDATE^DIE("E","^TMP(""DIAX"",$J)",IEN,DIAXERR)
 I $G(DIERR) D  Q
 . K ^TMP("DIAX",$J)
 . D ERR
 N %,NODE,A,B,FI,VAL,DA S %=0,NODE=DIAXTO
 I $G(@IEN@(1)) S DIAXDA=^(1),FI=0,FI=$O(@NODE@(FI))
 E  S FI=FRFILE
 F  S %=$O(@IEN@(%)) Q:'%  S DA=@IEN@(%) D VAL
Q2 K @IEN Q
VAL S NODE=DIAXTO,NODE=$NA(@NODE@(FI)) F  S NODE=$Q(@NODE) Q:NODE'["DIAXTO"  Q:$QS(NODE,5)'[$G(FRIENS)  S VAL=@NODE I VAL[("+"_%_Z)  S VAL=$P(VAL,"+"_%_Z,1)_DA_Z_$P(VAL,"+"_%_Z,2) S @NODE=VAL D
 . S A=$QS(NODE,3),B=$QS(NODE,5)
 . Q:(A'=DIAXF)&('$D(DIAXFILE(A)))
 . Q:A=""!(B="")
 . I A=DIAXF S B=+B,VAL=+VAL
 . S @DIAXRSLT@("RESULT",A,B)=VAL
 Q
RECURSE ;
 N DIAXIZ,DILLZ,DIERR
 S DIAXIZ=DIAXI,DILLZ=DILL
 D NEXTLVL,FILE
 N NODE,SUB,FILE S FILE=FRFILE
 F  S FILE=$O(@DIAXFR@(FILE)) Q:'FILE  F NODE=$NA(@DIAXFR@(FILE)),$NA(@DIAXTO@(FILE)) F  S NODE=$Q(@NODE) Q:NODE'["IENS"  S SUB=$QS(NODE,5) I SUB[FRIENS K @NODE
 K @DIAXFR@(FRFILE,"IENS",ZFRIENS,FRIENS),@DIAXTO@(FRFILE,"IENS",FRIENS)
 S DIAXI=DIAXIZ,DILL=DILLZ,A=""
 I $G(DIERR) K DIAXDA S DIERZ=1
 Q

DIAXERR
DIAXERR ;SFISC/DCM-EXTRACT MAPPING UTILITIES ;5/1/96  16:49
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ERR(A) ;
 Q:'$D(A)  N DIAXMSG
 S DIPG=+$G(DIPG),DIERR=($G(DIERR)+1)_U_($P($G(DIERR),U)+1)
 S DIAXMSG=$S(+A:$P($T(@(+A)),";",3),1:A)
 I DIPG S ^TMP("DIERR",$J,+DIERR)="",^(+DIERR,"TEXT",1)=DIAXMSG Q
 E  D EN^DDIOL(DIAXMSG)
 Q
5 ;;Destination file does not exist
6 ;;Mapping information does not exist
7 ;;Extract field does not exist
8 ;;Field in destination file does not exist

DIAXF
DIAXF ;SFISC/DCM-FILE EXTRACTED DATA ;5/13/96  14:01
 ;;21.0;VA FileMan;**8**;Jul 10, 1995
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 Q:'$D(^TMP("DIAX",$J))
 N DIAXDAZ
 S DIAXDAZ="^TMP(""DIAXDAZ"",$J)" K @DIAXDAZ
 D UPDATE^DIE("E","^TMP(""DIAX"",$J)",DIAXDAZ,DIAXERR)
 I $G(DIERR) D  Q
 . K ^TMP("DIAX",$J) I $D(@DIAXDAZ) D  Q
 . . N NODE,DA,DIK S NODE=$Q(@(DIAXDAZ))
 . . S DA=@NODE,DIK=DIAXDFRT
 . . D ^DIK K @DIAXDAZ Q
 S DIAXDA=@($Q(@DIAXDAZ)) K @DIAXDAZ
 Q

DIAXG
DIAXG ;SFISC/DCM-UPDATE DESTINATION FILE ;6/11/93  11:32 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN I $G(DIAXNTC)'=DIARP D EN^DIAXM G EOJ:$D(DIAXMSG) S DIAXNTC=DIARP
 ;
EN1 K ^TMP("DIAX",$J),DIAXDA
 D INIT^DIAXGI,BODY,EOJ
 Q
 ;
BODY D BASE Q:$D(DIAXMSG)
 D NEXTLVL
 Q
 ;
BASE D ^DIAXGU Q:$D(DIAXMSG)
 D FIELDS
 D ^DIAXU1 Q:$D(DIAXMSG)
 S DIAXDA=^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DA")
 Q
 ;
NEXTLVL S DIAX(DILL,"DIAXI")=DIAXI,DILL=DILL+1
 F DIAXI=DIAXI:0 S DIAXI=$O(^DIPT(DIARP,1,DIAXI)) Q:DIAXI'=+DIAXI  S X=^(DIAXI,0) D NEXTLVL2 Q:DIAXI=""!$D(DIAXMSG)
 S DILL=DILL-1,DIAXI=DIAX(DILL,"DIAXI")
 Q
 ;
NEXTLVL2 I $P(X,U,2)<DILL S DIAXI="" Q
 Q:$P(X,U,3)'=DIAX(DILL-1,"FILE")
 D FVARS^DIAXGI
 I DIAX(DILL,"XREF")?1A.E D DIAXG3^DIAXG2 Q
 I DIAX(DILL,"XREF")=3 D ^DIAXG2 Q
 Q:'DIAX(DILL,"FE")
 D ^DIAXGU Q:$D(DIAXMSG)
 D FIELDS
 D ^DIAXU1 Q:$D(DIAXMSG)
 D RECURSE
 Q
 ;
RECURSE D NEXTLVL
 Q
 ;
FIELDS D ^DIAXG1
 Q
 ;
EOJ K DIAXI,DILL,DIAXFI,DIAX,X,DIAXET,^TMP("DIAX",$J)
 K:'$D(DIAXMSG) DIAXFE
 Q

DIAXG1
DIAXG1 ;SFISC/DCM-EXTRACT FIELDS ;3/2/93  1:36 PM
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START K ^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"))
 D DRS
 Q
 ;
DRS S DR="",DIAXDRR="",DIAXDRZ=0
 F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAXI,"F",DIAX2)) Q:DIAX2'=+DIAX2  I $D(^(DIAX2,0)) S DRX=^(0),DR=DR_+DRX_";",DIAXDR(+DRX)=$P(DRX,U,3),DIAXEXT(+DRX)=$P(DRX,U,5) I $L(DR)>200 D DR S DR="",DIAXDRR=""
 D DR:DR]"" K DIAX2,DIAXDRZ Q
 ;
EN ;
DR I '$D(DIAX(DILL,"MUL")) S DIC=DIAX(DILL,"FILE"),DA=DIAX(DILL,"FE")
 S DIQ(0)="IEN" D EN^DIQ1 K DIQ
 F DIAX2(DILL,"FLD")=0:0 D DR2 Q:DIAX2(DILL,"FLD")'=+DIAX2(DILL,"FLD")  S X=^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),$S($G(DIAXEXT(DIAX2(DILL,"FLD"))):"E",1:"I")) D FIELD
 D ET
 I '$D(DIAX(DILL,"MUL")) K DA,DIC,DR,DIAXDRR,DIAXDR,DIAXEXT
 K ^UTILITY("DIQ1",$J,DIAX(DILL,"FILE")),DRX
 Q
 ;
DR2 S DIAX2(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"))) Q:DIAX2(DILL,"FLD")=""
 I $O(^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),0)) S V("WP")=0,^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),"I")="wp"
 Q
 ;
FIELD D:$L(DIAXDRR)+$L(X)>235 ET
 Q:'$D(DIAXDR(DIAX2(DILL,"FLD")))
 I DIAXDR(DIAX2(DILL,"FLD"))=".01" S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"X")=X G F2
 S:X[";" ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")))=X
 S:'$D(V) DIAXDRR=DIAXDRR_DIAXDR(DIAX2(DILL,"FLD"))_"///"_$S(X'[";":X,1:"^S X=^TMP(""DIAX"",$J,"_DIAXET(DILL,"FILE")_","_DIAXDR(DIAX2(DILL,"FLD"))_")")_";"
 D:$D(V)>9 WP
F2 K X,V
 Q
 ;
WP S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")),"DTO(1)")=^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL"),^("DTL")=1
 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")),"DFR(1)")=DIAX(DILL,"FGBL")_DIAX(DILL,"FE")_","""_$P($P(^DD(DIAX(DILL,"FILE"),DIAX2(DILL,"FLD"),0),U,4),";")_""",",^("DFL")=1
 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP",0)="",^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP",DIAXDR(DIAX2(DILL,"FLD")),0)=""
 Q
 ;
ET I '$D(^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR")) S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR")=DIAXDRR G ET1
 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR",$G(DIAXDRZ)+1)=DIAXDRR,DIAXDRZ=$G(DIAXDRZ)+1
 ;
ET1 S DIAXDRR=""
 Q

DIAXG2
DIAXG2 ;SFISC/DCM-EXTRACT SUBFILES ;9/2/94  06:35
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SUBFILE F DIAX(DILL,"FE")=0:0 S DIAX(DILL,"FE")=$O(@(DIAX(DILL,"FGBL")_DIAX(DILL,"FE")_")")) Q:DIAX(DILL,"FE")'=+DIAX(DILL,"FE")!($D(DIAXMSG))  D SUBENTRY
 Q
 ;
SUBENTRY ;
 N DIAXOUT
 D DR S DR(DIAX(DILL,"FILE"))=.01
 S DIAX(DILL,"MUL")=1
 D ^DIAXGU Q:$D(DIAXMSG)!$G(DIAXOUT)
 D DR,DRS
 D ^DIAXU1 G X1:$D(DIAXMSG)
 D RECURSEM
X1 K DIAX(DILL,"MUL"),DA,DR,DIAXDR,DIAXDRR,DIAXEXT,DIAX2,DRX
 Q
 ;
DR K DR S I=0
 F %=DIAX(DILL,"FILE"):0 Q:'$D(^DD(%,0,"UP"))  S X=^("UP"),Y=$O(^DD(X,"SB",%,0)),DR(X)=Y,DA(%)=DIAX(DILL-I,"FE"),%=X,I=I+1
 S DA=DIAX(DILL-I,"FE"),DIC=DIAX(DILL-I,"FILE"),DR=DR(%) K DR(%)
 Q
 ;
DRS S DR(DIAX(DILL,"FILE"))="",DIAXDRR=""
 F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAXI,"F",DIAX2)) Q:DIAX2'=+DIAX2  I $D(^(DIAX2,0)) S DRX=^(0) D
 . S DR(DIAX(DILL,"FILE"))=DR(DIAX(DILL,"FILE"))_+DRX_";",DIAXDR(+DRX)=$P(DRX,U,3),DIAXEXT(+DRX)=$P(DRX,U,5)
 . I $L(DR(DIAX(DILL,"FILE")))>200 D EN^DIAXG1 S DR(DIAX(DILL,"FILE"))=""
 D EN^DIAXG1:DR(DIAX(DILL,"FILE"))]""
 Q
 ;
RECURSEM D NEXTLVL^DIAXG
 Q
 ;
DIAXG3 ;
FILE F DIAX(DILL,"FE")=0:0 D FILE2 Q:DIAX(DILL,"FE")=""!($D(DIAXMSG))  D ENTRY
 K X
 Q
 ;
FILE2 S DIAX(DILL,"FE")=$O(@(DIAX(DILL,"FGBL")_""""_DIAX(DILL,"XREF")_""","_DIAX(DILL-1,"FE")_","_DIAX(DILL,"FE")_")"))
 Q
 ;
ENTRY S DIAX(DILL,"NAV")=1
 D ^DIAXGU Q:$D(DIAXMSG)
 K DIAX(DILL,"NAV")
 D ^DIAXG1
 D ^DIAXU1 G X1:$D(DIAXMSG)
 D RECURSEF
 Q
 ;
RECURSEF D NEXTLVL^DIAXG
 Q

DIAXGI
DIAXGI ;SFISC/DCM-EXTRACT INITIALIZATION ;11/10/92  2:56 PM
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
INIT S DIAXI=0,DILL=1
 D FIRST
 Q
 ;
FIRST S DIAXI=$O(^DIPT(DIARP,1,DIAXI)) Q:DIAXI'=+DIAXI
 S X=^(DIAXI,0)
 D FVARS
 Q
 ;
FVARS S DILL=$P(X,U,2),DIAX(DILL,"FILE")=+X,DIAXET(DILL,"FILE")=$P(X,U,9),(DIAXET(DILL,"PRT"),DIAXET(DIAXET(DILL,"FILE")))=$P(X,U,10)
 I DILL=1 S DIAX(DILL,"FE")=DIAXFE
 I $P(X,U,4)=1 S DIAX(DILL,"FE")=DIAX(DILL-1,"FE")
 S DIAX(DILL,"XREF")=$S($P(X,U,4)=4:$P(X,U,7),1:$P(X,U,4)),%=$P(X,U,5)
 I $E(%,$L(%))=":" S DIAX(DILL,"NAV")=1 I $P(X,U,4)=2 S DIAX(DILL,"NAV")=2 D DIRECT K %,Y
 I $P(X,U,4)=3 S %=$P(X,U,3),%=$O(^DD(%,"SB",+X,0)),%=^DD(+$P(X,U,3),%,0),%=$P($P(^(0),U,4),";") S:+%'=% %=""""_%_"""" S DIAX(DILL,"FGBL")=DIAX(DILL-1,"FGBL")_DIAX(DILL-1,"FE")_","_%_"," K DIAX(DILL,"NAV") D FGBL Q
 S DIAX(DILL,"FGBL")=^DIC(DIAX(DILL,"FILE"),0,"GL") D FGBL
 Q
 ;
DIRECT S DIAX(DILL,"FE")=0,%=$P(%,":")
 S:'$D(^DD(DIAX(DILL-1,"FILE"),"B",%)) %=$O(^(%))
 S %=$O(^DD(DIAX(DILL-1,"FILE"),"B",%,0))
 Q:%'=+%
 S Y=$P(^DD(DIAX(DILL-1,"FILE"),%,0),U,4),%("N")=$P(Y,";"),%("P")=$P(Y,";",2) S:+%("N")'=%("N") %("N")=""""_%("N")_""""
 I $D(@(DIAX(DILL-1,"FGBL")_DIAX(DILL-1,"FE")_","_%("N")_")")) S Y=@("^("_%("N")_")"),DIAX(DILL,"FE")=$P(Y,U,%("P"))
 Q
 ;
FGBL S DIAXFI=+$P(X,U,10) I 'DIAXFI Q
 I DILL=1 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL")=^DIC(DIAXET(DILL,"FILE"),0,"GL") Q
 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL")=^TMP("DIAX",$J,DIAXFI,"GL")_$S(DIAXET(DILL,"FILE")'=DIAXFI:^TMP("DIAX",$J,DIAXFI,"DA")_$S($P(X,U,11)]"":","""_$P($P(X,U,11),";")_""",",1:","),1:"")
 S:$D(^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP")) ^("DTO(1)")=^("GL") S ^("DA(1)")=DIAXET(DIAXFI,"DA")
 I $G(DIAXET(DIAXFI,"DA(1)"))]"" F DIAXII=1:1 Q:'$D(DIAXET(DIAXFI,"DA("_DIAXII_")"))  S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DA("_(DIAXII+1)_")")=DIAXET(DIAXFI,"DA("_DIAXII_")")
 K DIAXFI,DIAXII
 Q

DIAXGU
DIAXGU ;SFISC/DCM-EXTRACT FUNCTIONS ;9/2/94  06:40
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOOKUP D SETX G Q:$D(DIAXMSG)!$G(DIAXOUT)
 D ET
Q K X,X1,^UTILITY("DIQ1",$J),DIQ
 Q
 ;
SETX I '$D(DIAX(DILL,"MUL")) S DIC=DIAX(DILL,"FILE"),DA=DIAX(DILL,"FE"),DR=".01" I '$D(@(DIAX(DILL,"FGBL")_DA_",0)")) D ERR^DIAXERR(97,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX^DIAXU2 Q
 S DIQ(0)="EIN" D EN^DIQ1
 S X=^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),.01,"E"),X1=^("I")
 I DILL=1 S DIAX(DILL,.01)=X
 I $D(DIAX(DILL,"MUL")),$G(DIAXSCR(DIAX(DILL,"FILE")))]"" D
 .N X S X=X1 X DIAXSCR(DIAX(DILL,"FILE")) S:'$T DIAXOUT=1
 Q
 ;
ET I '$D(DIAX(DILL,"MUL")) K DA,DIC,DR
 I DIAX(DILL,"XREF")=2 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"MODE")="M" Q
 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"X")=X,^("MODE")="A"
 I $D(DIAX(DILL,"MUL"))!(DIAX(DILL,"XREF")?1A.E) S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DIC(""P"")")=DIAXET(DILL,"FILE")
 Q

DIAXM
DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93  4:04 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ASK S DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1
 I $D(DC(DC)),$P(DC(DC),U,3)]"",'DINS S DIAXDEF=$P($G(^DD(DIAXF,$P(DC(DC),U,3),0)),U)_"// "
 W !?DIAXTAB,"MAP ",DIAXDICA," TO ",DIAXEF,$S($D(DIAXSB):" SUB-FIELD: ",1:" FIELD: ") W:'DINS $G(DIAXDEF)
 R DIAXX:DTIME I '$T S (DTOUT,DIRUT)=1 Q
 I DIAXX="",$D(DIAXDEF) S X=$P(DIAXDEF,"//") G ASK1
 I DIAXX=U S (DUOUT,DIRUT)=1 Q
 I $D(DIAXDEF),DIAXX="@" S $P(DC(DC),U,3)="" K DIAXDEF G ASK
 I DIAXX="" W !?DIAXTAB,$C(7),DIAXDICA," will not be extracted" K DIAXDICA Q
 S X=DIAXX
ASK1 D DIC I Y'>0 W:X'["?" $C(7),"??",!?DIAXTAB,"Check available fields for mapping by typing '??'." G ASK
 I +$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S DIAX1=$P(Y(0),U,4),Y(0)=^(0),$P(Y(0),U,4)=DIAX1
 S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y K:+Y=.01 DIAXE01(DIAXFILE)
 D PR
 Q
DIC K DIC,Y
 S DIAXS1="$P(^(0),U,2)",DIC="^DD("_DIAXF_",",DIC(0)="ZE"_$E("O",DC>0)
 D DICS
 S DIC("S")=DIC("S")_",'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U)"
 D ^DIC
 Q
 ;
DICS I DIAXFT["W" S DIC("S")="I +"_DIAXS1_",$P(^DD(+"_DIAXS1_",.01,0),U,2)[""W""" Q
 I DIAXFT["C" S DIC("S")="I "_DIAXS1_"[""F""!("_DIAXS1_"["""_$S(DIAXFT["D":"D"")",1:"N"")") Q
 S DIC("S")="I "_DIAXS1_"["""_$S(DIAXFT["K":"K""",1:"F""")_$S(DIAXFT["D":"!("_DIAXS1_"[""D"")",DIAXFT["N"!(DIAXFT["P"&'$G(DIAXEXT)):"!("_DIAXS1_"[""N"")",1:"")_$S((DIAXFT["S"&'$G(DIAXEXT)):"!("_DIAXS1_"[""S"")",1:"")
 Q
PR S DIAXTO=1,DIAXFR=0
 D EN1
 Q
EN S DIPG=+$G(DIPG) N DIAXF
 W:'DIPG !!,"Excuse me, this will take a few moments...",!,"Checking the destination file...",!
 I '$P(^DIPT(DIARP,0),U,9)!('$D(^DIC(+$P(^DIPT(DIARP,0),U,9),0))) D ERR^DIAXERR(5) Q
 I '$D(^DIPT(DIARP,1,0)) D ERR^DIAXERR(6) Q
 F DIAX1=0:0 S DIAX1=$O(^DIPT(DIARP,1,DIAX1)) Q:DIAX1'>0  S DIAX41=^(DIAX1,0),(DIAXDK,DK)=+DIAX41,DIAXDL=$P(DIAX41,U,2),DIAXF=$P(DIAX41,U,9),DIAXEF=$O(^DD(DIAXF,0,"NM",0)) D   D IX^DIAXMS
 . S DIAXLNK=+$P(DIAX41,U,4),DIAXE01(DIAXF)=$S(DIAXLNK>2:+$P(DIAX41,U,3),1:DIAXDK)_U_(DIAXLNK>2)
 . F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAX1,"F",DIAX2)) Q:DIAX2'>0  S DIAX42=^(DIAX2,0),DIAXEXT=+$P(DIAX42,U,5) D
 . . K DIC S X=+DIAX42,DIC="^DD(DIAXDK,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(7) Q
 . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
 . . S DIAXFR=1,DIAXTO=0,DIAXTAB=0 D EN1
 . . K Y,DIC
 . . I DIAXF#1 S DIAXSB=1
 . . S X=$P(DIAX42,U,3),DIC="^DD(DIAXF,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(8) K DIAXFR Q
 . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
 . . I +Y=.01 K DIAXE01(DIAXF)
 . . D PR,Q
 . . K DIAXSB
 I $D(DIAXE01) D F1^DIAXMS
 I $G(DIERR),'DIPG,DIAR=6 W !!,$C(7),"Sorry, I can not proceed with the update.  Your destination file needs fixing",!,"first."
 I '$G(DIERR),'DIPG,DIAR="" W !,$C(7),"Template looks OK!"
 D Q,Q1^DIAXMS
 Q
EN1 D IN Q:($D(DIAXMSG)&'$D(DIAR))
 D EN^DIAXM1
 Q
IN S DIAXFT=$P(Y(0),U,2),DIAXFTY=$$TYP^DIAXMS(DIAXFT) Q:($D(DIAXMSG)&'$D(DIAR))
 S DIAXA=$S($D(DIAXVPTR):"DIAXVFR",DIAXFR:"DIAXFR",1:"DIAXTO")
 S @(DIAXA_"(""TY"")")=DIAXFT,@(DIAXA_"(""NM"")")=Y(0,0),@(DIAXA_"(""TYP"")")=DIAXFTY
 I "FN"[DIAXFTY S DIAXHI=+$P($P(Y(0),U,5,9),">",2),DIAXLO=+$P($P(Y(0),U,5,9),"<",2) D HL(DIAXHI,DIAXLO)
 Q
Q D Q^DIAXMS
 Q
EN2 S DIAXDICA=Y(0,0),DIAXFR=1,DIAXTO=0,DIAXC=C,DIAXDJ=DJ,DIAXS=S,DIPG=0,DIAXTAB=+$G(DIAXTAB)
 D EN1 I $D(DIAXMSG)!$D(DIRUT) K Y D Q Q
 D ASK,Q
 Q
HL(A,B) S:A]"" @(DIAXA_"(""HI"")")=+A
 S:B]"" @(DIAXA_"(""LO"")")=+B
 Q

DIAXM1
DIAXM1 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;7/11/95  06:33
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN D @DIAXFTY Q:DIAXFR  Q:$D(DIAXMSG)
 I DIAXFR("TYP")'=DIAXTO("TYP"),'$D(DIAXEXT) S DIAXEXT=1
 D:'$D(DIAR) DJ
 Q
 ;
F Q:DIAXFR!($D(DIAXMSG))  I DIAXFR("TY")["C" D CF^DIAXM2 Q
 I "FSP"[DIAXFR("TYP"),+DIAXFR("LO"),DIAXFR("LO")<DIAXTO("LO") S DIAXE2=DIAXFR("LO") D E1,E3
 I "FSP"[DIAXFR("TYP"),DIAXFR("HI")>DIAXTO("HI") S DIAXE2=DIAXFR("HI") D E2
 I DIAXFR("TY")["N",DIAXFR("LE")<DIAXTO("LO") S DIAXE2=DIAXFR("LE") D E1,E3
 I DIAXFR("TY")["N",DIAXFR("LE")>DIAXTO("HI") S DIAXE2=DIAXFR("LE") D E2
 I DIAXFR("TY")["D",DIAXTO("LO")>14 S DIAXE2=14 D E1,E3
 I DIAXFR("TY")["D",DIAXTO("HI")<14 S DIAXE2=14 D E2
 Q
 ;
N G N^DIAXM3
 ;
D G D^DIAXM3
 ;
P D XT I DIAXEXT D P^DIAXM2 Q:$D(DIAXMSG)!DIAXFR
 D HL^DIAXM(15,1)
 Q
 ;
V D XT I DIAXEXT D V^DIAXM2 Q:$D(DIAXMSG)!DIAXFR
 D HL^DIAXM(30,3)
 Q
 ;
C G C^DIAXM2
 ;
S I DIAXTO W:'$D(DIAR) !?DIAXTAB,$C(7),"Make sure the SET OF CODES are identical as the extract field." Q
 D XT D S^DIAXM2
 Q
 ;
W Q:DIAXFR
 I DIAXFR("TY")["L",DIAXTO("TY")'["L" D E3 S DIAXEM=DIAXEM_"be in 'L'ine mode." D X
 Q
 ;
K Q
 ;
E1 S DIAXE1="minimum" Q
E2 S DIAXE1="maximum"
E3 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q:DIAXFTY["W"
 S DIAXEM=DIAXEM_"have a "_DIAXE1_" length of at least "_DIAXE2_" characters."
X D ERR^DIAXERR(DIAXEM)
 K DIAXE1,DIAXE2
 Q
 ;
DJ S DIAXDJ=DIAXDJ+1
 S ^UTILITY("DIFG",$J,DIAXC,DIAXDJ)=DIAXS_U_U_+Y_U_$P(Y(0),U,4)_U_$G(DIAXEXT)
 S S=DIAXS,DJ=DIAXDJ,C=DIAXC
 Q
 ;
XT S DIAXEXT=+$G(DIAXEXT) I '$D(DIAR),$D(DC(DC)) S DIAXEXT=+$P(DC(DC),U,5) Q:'DINS
 Q:$D(DIAR)
 K DIR N Y S DIR(0)="Y",DIR("A")="Move EXTERNAL form of the data to the extract field",DIR("B")="Yes",DIR("?")="Answer YES if the RESOLVED value of data should be moved"
 D ^DIR K DIR Q:'Y
 S DIAXEXT=1
 Q

DIAXM2
DIAXM2 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;3/11/93  2:59 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
P K DIC
 ;
P1 S DIC="^DD("_+$P($P(Y(0),U,2),"P",2)_",",DIC(0)="Z",X=.01
 D ^DIC I Y'>0 S DIAXEM=DIAXFR("NM")_" points to missing pointed to file." D E Q
 S DIAXFTY=$$TYP^DIAXMS($P(Y(0),U,2)) Q:$D(DIAXMSG)
 I $P(Y(0),U,2)["P" G P1
 Q:$D(DIAXVPTR)
 D EN1^DIAXM
 Q
V S DIAXVPTR=1,DIAXZZ=0,DIAXVFLD=+Y,DIAXVFI=DK
 ;
V1 F  S DIAXZZ=$O(^DD(DK,DIAXVFLD,"V","B",DIAXZZ)) Q:DIAXZZ'>0  D V2 Q:$D(DIAXMSG)
 Q:$D(DIAXMSG)
 S DIAXFR("TY")=$S(DIAXFR("TY")["F":DIAXFR("TY"),1:"F"),DIAXFR("TYP")="F"
 S DIAXFR("LO")=$S(+DIAXFR("LO")+1:DIAXFR("LO"),1:3)
 S DIAXFR("HI")=$S(+DIAXFR("HI")+1:DIAXFR("HI"),1:45)
 S DIAXFT=DIAXFR("TY"),Y(0)=U_DIAXFT K DIAXVPTR D EN^DIAXM1
 Q
V2 S DIC="^DD(+DIAXZZ,",DIC(0)="Z",X=.01 D ^DIC I Y'>0 S DIAXEM="Missing pointed to file." D E Q
 I $P(Y(0),U,2)["P" D P1 Q:$D(DIAXMSG)
 D IN^DIAXM Q:$D(DIAXMSG)
 S DIAXFR("TY")=$S($G(DIAXFR("TY"))["F":DIAXFR("TY"),1:DIAXVFR("TY"))
 S:DIAXVFR("TY")["F" DIAXFR("LO")=$S(+$G(DIAXFR("LO"))<DIAXVFR("LO"):+$G(DIAXFR("LO")),1:DIAXVFR("LO"))
 S:DIAXVFR("TY")["F" DIAXFR("HI")=$S(+$G(DIAXFR("HI"))>DIAXVFR("HI"):+$G(DIAXFR("HI")),1:DIAXVFR("HI"))
 Q
 ;
S S DIAXZ=$P(Y(0),U,3),DIAXZL=0,DIAXPC=$S(DIAXEXT:2,1:1)
 F DIAXZZ=1:1:$L(DIAXZ,";") S DIAXZY=$P(DIAXZ,";",DIAXZZ) Q:DIAXZY=""  S DIAXZL=$S($L($P(DIAXZY,":",DIAXPC))>+DIAXZL:$L($P(DIAXZY,":",DIAXPC)),1:+DIAXZL),DIAXZLL=$S(+$G(DIAXZLL)<DIAXZL:+$G(DIAXZLL),1:DIAXZL)
 D HL^DIAXM(DIAXZL,DIAXZLL)
 Q
 ;
C S DIAXFR("DC")=+$P($P(Y(0),U,2),",",2)
 S DIAXFR("LE")=+$P($P(Y(0),U,2),"J",2)
 Q
 ;
CN I DIAXFR("TY")["B",DIAXTO("LO")'=0 D E1 S DIAXEM=DIAXEM_"have a minimum value of 0." D E Q
 I DIAXFR("TY")["J",DIAXTO("DC")<DIAXFR("DC") D E1 S DIAXEM=DIAXEM_"have at least "_DIAXFR("DC")_" decimal places." D E
 I DIAXFR("TY")["J",DIAXFR("LE")>DIAXTO("LE") D E1 S DIAXEM=DIAXEM_"be at least "_DIAXFR("LE")_" characters long." D E
 Q
 ;
CF I DIAXFR("TY")["B",DIAXTO("LO")'=1 D E1 S DIAXEM=DIAXEM_"have a minimum length of 1." D E Q
 Q:DIAXFR("TY")["B"
 I DIAXFR("TY")["D",DIAXTO("LO")>7 D E1 S DIAXEM=DIAXEM_"a minimum length of at least 7." D E
 I DIAXFR("TY")["D",DIAXTO("HI")<7 D E1 S DIAXEM=DIAXEM_"a maximum length of at least 7." D E
 I DIAXFR("TY")["J",DIAXFR("LE")<DIAXTO("LO") D E1 S DIAXEM=DIAXEM_"have a minimum length of at least"_DIAXFR("LE")_" characters." D E
 I DIAXFR("TY")["J",DIAXFR("LE")>DIAXTO("HI") D E1 S DIAXEM=DIAXEM_"have a maximum length of at least "_DIAXFR("LE")_" characters." D E
 Q
 ;
CD I DIAXFR("TY")["D",+DIAXTO("LO")!+DIAXTO("HI") D E1 S DIAXEM=DIAXEM_"not have set date ranges." D E
 Q
 ;
E1 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q
 ;
E D ERR^DIAXERR(DIAXEM)
 Q

DIAXM3
DIAXM3 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;3/3/93  12:23 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
N S DIAXNO=$P(Y(0),U,2),DIAXLE=+$P(DIAXNO,"J",2) S:DIAXFR DIAXFR("DLR")=$P(Y(0),U,5)["$"
 S @(DIAXA_"(""LE"")")=DIAXLE,@(DIAXA_"(""DC"")")=+$P(DIAXNO,",",2)
 Q:DIAXFR  I DIAXFR("TY")["C" D CN^DIAXM2 Q
 I DIAXFR("TY")["P" G N1
 I DIAXFR("DLR"),DIAXTO("DC")<2 D E3 S DIAXEM=DIAXEM_"contain at least 2 decimal places." D E
 I DIAXFR("DC")>DIAXTO("DC") D E3 S DIAXEM=DIAXEM_"contain at least "_DIAXFR("DC")_" decimal places." D E
 I DIAXFR("LE")>DIAXTO("LE") D E3 S DIAXEM=DIAXEM_"be at least "_DIAXFR("LE")_" digits long." D E
N1 I DIAXTO("LO")>DIAXFR("LO") S DIAXE2=DIAXFR("LO") D E1,E3,E4
 I DIAXTO("HI")<DIAXFR("HI") S DIAXE2=DIAXFR("HI") D E2,E4
 Q
 ;
D S DIAXDT=$P(Y(0),U,5,99),DIAXLO=$P($P(DIAXDT,"<X!(",2),">X"),DIAXHI=$P($P(DIAXDT,"K:",2),"<X!(")
 S @(DIAXA_"(""DT"")")=$P(DIAXDT,"""",2) D HL^DIAXM(+DIAXHI,+DIAXLO)
 Q:DIAXFR  I DIAXFR("TY")["C" D CD^DIAXM2 Q
 I DIAXTO("DT")["R",DIAXFR("DT")'["R" D E3 S DIAXEM=DIAXEM_"not 'R'equire time." D E
 I DIAXTO("DT")["S",DIAXFR("DT")'["S" D E3 S DIAXEM=DIAXEM_"not expect 'S'econds to be returned." D E
 I DIAXTO("DT")["X",DIAXFR("DT")'["X" D E3 S DIAXEM=DIAXEM_"not require e'X'act date." D E
 I DIAXTO("LO"),'DIAXFR("LO") D E3 S DIAXEM=DIAXEM_"not have an earliest date." D E
 I DIAXTO("HI"),'DIAXFR("HI") D E3 S DIAXEM=DIAXEM_"not have a latest date." D E
 I DIAXTO("LO"),DIAXTO("LO")>DIAXFR("LO") S DIAXDTY=DIAXFR("LO") D DT,E3 S DIAXEM=DIAXEM_"have an earliest date of at least "_DIAXDTY D E
 I DIAXTO("HI"),DIAXTO("HI")<DIAXFR("HI") S DIAXDTY=DIAXFR("HI") D DT,E3 S DIAXEM=DIAXEM_"have a latest date of at least "_DIAXDTY D E
 Q
 ;
DT N Y
 S Y=DIAXDTY X ^DD("DD") S DIAXDTY=Y
 Q
 ;
E1 S DIAXE1="minimum" Q
E2 S DIAXE1="maximum"
E3 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q
E4 S DIAXEM=DIAXEM_"have a "_DIAXE1_" value of at least "_DIAXE2
E D ERR^DIAXERR(DIAXEM)
 K DIAXE1,DIAXE2
 Q

DIAXMS
DIAXMS ;SFISC/DCM-MAP SUBFILES ;9/2/94  06:17
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIAXSB=1,DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1 S $P(DIAXTABZ," ",DIAXTAB)=" "
 W !,$C(7),?DIAXTAB,DIAXDICA," is a multiple valued field",!,?DIAXTAB,"It MUST be mapped to a subfile."
 K DIC,DIAXUP N Y
 I $D(DC(DC)),$P(DC(1),U,3)]"" S DIAXDEF=$P(DC(1),U,3)
 S DIC="^DD(DIAXF,",DIC(0)="QEAZ",DIC("S")="I $P(^(0),U,2),'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""P"",$P(^(0),U,2)'[""W"",$P(^(0),U,2)'[""V"""
 S DIC("A")=DIAXTABZ_"MAP "_DIAXDICA_" TO "_DIAXEF_" SUBFILE: " S:$D(DIAXDEF) DIC("B")=DIAXDEF
 D ^DIC I Y'>0 S DIAXUP=1 W:X=""&'$D(DTOUT) !,$C(7),DIAXDICA_" will not be extracted" S:$D(DTOUT) DIRUT=1 G QQ
 S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y,DIAXEF=Y(0,0)
 S (DIAXFILE,DIAXF)=+$P(Y(0),U,2),DIAXLOC(DIAXFILE)="",DIAXNP(DL-1)=$P(Y(0),U,4)
QQ K DIAXDEF,DIAXDICA
 Q
IX Q:$P($G(^DD($$FNO^DILIBF(DIAXF),0,"DI")),U)'["Y"
 S (DIAXIX,DIAXFI,DIAXFD)=""
 F  S DIAXIX=$O(^DD(DIAXF,0,"IX",DIAXIX)) Q:DIAXIX=""  F  S DIAXFI=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI)) Q:DIAXFI'>0  F  S DIAXFD=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI,DIAXFD)) Q:DIAXFD'>0  D
 . I '$D(^DD(DIAXFI,DIAXFD,1)) S DIAXEM="Erroneous 'IX' node for "_DIAXIX D ERR^DIAXERR(DIAXEM) Q
 . S DIAXIXN=0 F  S DIAXIXN=$O(^DD(DIAXFI,DIAXFD,1,DIAXIXN)) Q:DIAXIXN'>0  S DIAXIX0=$P(^(DIAXIXN,0),U,2) Q:DIAXIX=DIAXIX0
 . Q:DIAXIXN'>0  S DIAXIX0=$P(^DD(DIAXFI,DIAXFD,1,DIAXIXN,0),U,3) D
 . . Q:DIAXIX0=""
 . . I DIAXIX0["MNE"!(DIAXIX0["REG")!(DIAXIX0["KWI")!(DIAXIX0["SOU") Q
 . . S DIAXEM="The """_DIAXIX_""" cross-reference in "_$P(^DD(DIAXFI,DIAXFD,0),U,1)_" is not allowed for an archive file." D ERR^DIAXERR(DIAXEM) Q:DIPG
 Q
 ;
Q K DIAXZ,DIAXFT,DIAXHI,DIAXLO,DIAXNO,DIAXLE,DIAXTABZ,DIC,DIAXDICA,DIAXS,DIAXDJ,DIAXC
 K DIAXDEF,DIAXA,DIAXX,DIAXFR,DIAXTO,DIAXS1,DIAXDT,DIAXZL,DIAXZLL,DIAXZY,DIAXZZ
 K DIAXIX,DIAXIX0,DIAXIXN,DIAXVFI,DIAXVFLD,DIAXVFR,DIAXDTY
 K DIAX41,DIAX42,DIAXFTY,DIAXEXT,DIAXE1,DIAXE2,DIAXPC I '$G(DIPG),'$G(DIAR)!($G(DIAR)=6) K DIAXMSG
 Q
Q1 K DIAXDK,DIAXDL,DIAXEF,DIAXF,DIAXFD,DIAXIX,DIAXIX0,DIAXIXN,DIAXTAB
 K DIAX1,DIAX2,DIAXFI,DIAXEM,DIAXLNK
 Q
F1 S (A1,B1,D1)=0 S:'$D(DIAR) DIAR=""
 F  S A1=$O(DIAXE01(A1)) Q:A1'>0  S B1=$G(DIAXE01(A1)),C="DIAXFR" S:+$P(B1,U,2) DIAXSB=1 D EN(B1,C) S C="DIAXTO",DIAXFR=0 D EN(A1,C) K DIAXSB
 K DIAXE01,A1,B1,D1 Q
EN(W,Z) S @Z=1
 S DIC="^DD("_+W_",",X=.01,DIC(0)="Z",DIAXEF=$O(^DD(+W,0,"NM","")) D ^DIC I Y'>0 Q
 D EN1^DIAXM
 Q
TYP(%) N W,W1,W2,X,Y
 S W="NPSVWCDFK",W1=%
 F X=1:1:$L(W) S W2=$F(W1,$E(W,X)) Q:W2
 S Y=$E(W1,W2-1)
 S:Y="" Y="F"
 Q Y

DIAXP
DIAXP ;SFISC/DCM-EXCEPTION REPORT ;5/16/96  10:56
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N PAGE,LINE,DIAXX,FILE,FNAME,Y,DATE,DIRUT,Z
 S PAGE=0,LINE="",DIAXX=^DIAR(1.11,DIARC,0),FILE=$P(DIAXX,U,2),FNAME=$P($G(^DIC(FILE,0)),U)
 S Y=DT X ^DD("DD") S DATE=Y
 D HDR,BODY,END
 Q
 ;
C I IOST["C-" N DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
 ;
HDR W:$Y @IOF W !,"EXTRACT ACTIVITY EXCEPTION REPORT",?IOM-24,DATE,?IOM-10,"PAGE: ",PAGE+1
 S PAGE=PAGE+1,$P(LINE,"-",IOM)="" W !,LINE
 Q
 ;
BODY W !!,"EXTRACT ACTIVITY: ",DIARC,?31,"ARCHIVER: ",$P($G(^VA(200,$P(DIAXX,U,6),0)),U)
 W !!,"THE FOLLOWING RECORDS IN THE '"_FNAME_"' FILE WERE NOT PROCESSED BY THE",!,"EXTRACT TOOL"
 N REC,LINE,ERR S REC=0 D REC Q:$D(DIRUT)
 W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
 Q
REC S LINE="Entry # "
 S REC=$O(^TMP("DIAXU",$J,"RESULT","ERR",FILE,REC)) Q:'REC  S ERR=^(REC)
 S LINE=LINE_+REC_" was NOT processed because:"
 D C:($Y+3>IOSL) Q:$D(DIRUT)
 W !!,LINE N A,B S A=1 D ERR
 G REC
ERR S B=$P(ERR,";",A) Q:B=""  S A=A+1
 N Z S Z=0
 F  S Z=$O(^TMP("DIERR",$J,+B,"TEXT",Z)) Q:'Z  D C:($Y+1>IOSL) Q:$D(DIRUT)  W !?2,$G(^(Z))
 G ERR
 ;
END I $E(IOST)'="C",$Y W @IOF
 D ^%ZISC
 K ^TMP("DIAXU",$J),^TMP("DIERR",$J)
 Q

DIAXT
DIAXT ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96  14:01
 ;;21.0;VA FileMan;**8**;Jul 10, 1995
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN N DIAXI,DILL,DIAX
 S DIAXTTO="^TMP($J,""DIAXTTO"")",DIAXTFR="^TMP($J,""DIAXTFR"")"
 K @DIAXTTO,@DIAXTFR
 D SPEC
 Q
SPEC ;get specs
 D TOP,DR
 D NEXTLVL
 Q
TOP ;get base file specs from extract template
 N X
 S DIAXI=0
 S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'>0  S X=^(DIAXI,0)
 S DILL=$P(X,U,2)
FILE S @DIAXTFR@(DIAXI,"FR")=+X
 S @DIAXTFR@(+X,"TO")=$P(X,U,9)
 S @DIAXTFR@(+X,"PRT")=$P(X,U,3)
 S @DIAXTFR@(+X,"P4")=$P(X,U,4)
 S @DIAXTFR@(+X,"P2")=$P(X,U,2)
 S @DIAXTFR@(+X,"P5")=$P(X,U,5)
 S @DIAXTFR@(+X,"P7")=$P(X,U,7)
 I DILL>1,$P(X,U,9)'=$P(X,U,10) S @DIAXTTO@(+$P(X,U,9),"PRT")=+$P(X,U,10)
 Q
DR ;get fields
 N DR,DRN,DRX,DRZ,FILE
 S DR="",DRN=1,DRZ=0,FILE=@DIAXTFR@(DILL,"FR")
 F  S DRZ=$O(^DIPT(DIAXT,1,DIAXI,"F",DRZ)) Q:'DRZ  I $D(^(DRZ,0)) S DRX=^(0) D
 . S DR=DR_+DRX_";",FILE=@DIAXTFR@(DIAXI,"FR")
 . S @DIAXTTO@(FILE,+DRX,+$P(DRX,U,5))=@DIAXTFR@(FILE,"TO")_U_$P(DRX,U,3)_U_$P(DRX,U,5)
 . I $L(DR)>245 S @DIAXTFR@(FILE,"DR",DRN)=DR,DRN=DRN+1,DR=""
 S:DR]"" @DIAXTFR@(FILE,"DR",DRN)=DR
 Q
NEXTLVL ;
 S DIAX(DILL,"DIAXI")=DIAXI,DILL=DILL+1
 F DIAXI=DIAXI:0 S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'=+DIAXI  S X=^(DIAXI,0) D NEXTLVL2 Q:DIAXI=""
 S DILL=DILL-1,DIAXI=DIAX(DILL,"DIAXI")
 Q
NEXTLVL2 ;
 I $P(X,U,2)<DILL S DIAXI="" Q
 Q:$P(X,U,3)'=@DIAXTFR@(DIAX(DILL-1,"DIAXI"),"FR")
 D FILE
 D DR
 D RECURSE
 Q
RECURSE ;
 D NEXTLVL
 Q

DIAXU
DIAXU ;SFISC/DCM-UPDATE DESTINATION FILE ;8/16/96  16:42
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
DIAX ;called from ^DIAX (Update Destination File option)
DQ ;
 I $D(ZTQUEUED) N DIAR,DIAX S ZTREQ="@",DIAR=6,DIAX=1 D MRK^DIARU
 N DIAXF,DIAXFRT S DIAXF=$P(^DIAR(1.11,DIARC,0),U,2),DIAXFRT=$$ROOT^DILFD(DIAXF)
 D EXTRACT(DIAXF,DIARB,DIARP)
 D UPDATE^DIARU
 I $D(ZTQUEUED),$G(DIERR) S ZTIO=DIAXIOP,ZTRTN="XREP^DIAXU",ZTDESC="EXTRACT TOOL EXCEPTION REPORT",ZTSAVE("^TMP(""DIAXU"",$J)")="",ZTSAVE("^TMP(""DIERR"",$J)")="",ZTSAVE("DIARC")="" D ^%ZTLOAD Q 
XREP ;
 I $D(ZTQUEUED) S ZTREQ="@"
 D ^DIAXP
 Q
EN ; obsolete, replaced by EXTRACT
 N %,DIAXERR S DIAXERR=""
 D CLEAN^DIEFU
 F %=$G(DIAXF)_U_"DIAXF",$G(DIAXFE)_U_"DIAXFE",$G(DIAXT)_U_"DIAXT" I $P(%,U,1)']"" D ERR(201,$P(%,U,2))
 Q:$G(DIERR)
 D EXTRACT(DIAXF,DIAXFE,DIAXT,$S($D(DIAXDEL):"D",1:""))
 I '$G(DIERR),$D(^TMP("DIAXU",$J,"RESULT",DIAXF,DIAXFE)) S DIAXDA=^(DIAXFE)
 Q
 ;
DIPT N X,D,SCR,DIARP,DIAR,DIPG
 S X=$S(DIAXT:DIAXT,1:$P($P(DIAXT,"[",2),"]")),D="F"_DIAXF,SCR="I $P(^(0),U,8)=2"
 S DIARP=$$FIND1^DIC(.4,"","XA",X,D,SCR,DIAXERR)
 Q:$G(DIERR)  I 'DIARP D ERR(202,"EXTRACT TEMPLATE") Q
 S DIAR=6,DIPG=1,DIAXT=DIARP,DIAXDF=$P(^DIPT(DIAXT,0),U,9),DIAXDFRT=$$ROOT^DILFD(DIAXDF)
 D EN^DIAXM
 Q
DIK N DIK,DA
 S DIK=$$ROOT^DILFD(DIAXF),DA=DIAXFE
 D ^DIK
 Q
K K @DIAXTFR,@DIAXTTO
 Q
ONE I '$$VENTRY^DIEFU(DIAXF,DIAXFE) D ERR(601,DIAXFE),STE() Q
 D ^DIAXD I $G(DIERR) D:$D(DIAXFILE)  D STE() Q
 . N DIERR,A S A("IEN")=DIAXFE
 . D BLD^DIALOG(1300,"",.A)
 D ^DIAXF I $G(DIERR) D STE() Q
 Q:$D(DIAX)
 I $G(DIAXFLGS)["D" D DIK
 I $G(DIAXDA) S @DIAXRSLT@("RESULT",DIAXF,DIAXFE)=DIAXDA
 Q
 ;
DIBT N SCR,D
 S D="F"_DIAXF,SCR="I $P(^(0),U,4)="_DIAXF_",'$P(^(0),U,8)"
 S DIAXST=$S($G(DIAXST):DIAXST,1:$$FIND1^DIC(.401,"","AX",DIAXST,D,SCR,DIAXERR))
 I 'DIAXST!('$D(^DIBT(DIAXST,1))) D ERR(202,"SEARCH TEMPLATE") S:$G(DIAR) DIAR="" Q
 N Z S Z=0 F  S Z=$O(^DIBT(DIAXST,1,Z)) Q:Z'>0  D
 . N DIAXDA,DIAXFE,DIERR
 . S DIAXFE=Z
 . D ONE
 . Q:$G(DIERR)
 . I $G(DIAX) D  Q
 . . N FDA,IEN
 . . S FDA(1.14,"+"_+DIAXFE_","_DIARC_",",.01)=DIAXDA,IEN(DIAXFE)=DIAXDA
 . . D UPDATE^DIE("","FDA","IEN")
 . . S @(DIAXFRT_"DIAXFE,-9)")=DIARC
 . I $G(DIAXFLGS)["D" K ^DIBT(DIAXST,1,DIAXFE)
 Q
STE(FI,IEN) N Z
 S:$G(FI)="" FI=DIAXF
 S:$G(IEN)="" IEN=DIAXFE
 S DIERRZ=(DIERR+DIERRZ)_U_($P(DIERR,U,2)+($P(DIERRZ,U,2)))
 F DIERRLST=DIERRLST:1:$O(^TMP("DIERR",$J,"E"),-1) S Z=DIERRLST_";"
 S @DIAXRSLT@("RESULT","ERR",FI,IEN)=Z
 Q
ERR(DIAXER,DIAXTXT) ;
 D BLD^DIALOG(DIAXER,DIAXTXT,"",DIAXERR,"F")
 Q
EXTRACT(DIAXF,DIAXSRCE,DIAXT,DIAXFLGS,DIAXSCR,DIAXFILE,DIAXRSLT,DIAXERRA) ;
 N DIAXST,DIAXFE,T,DIFM,DIOVRD,DIERRLST,DIAXTFR,DIAXTTO,DIAXDF,DIAXDFRT,DIAXERR,DIERRZ,DIAXDA
 S DIAXRSLT=$S($G(DIAXRSLT)]"":DIAXRSLT,1:"^TMP(""DIAXU"",$J)"),(DIFM,DIOVRD)=1,(DIERRLST,DIERRZ)=0,DIAXERR=""
 K ^TMP("DIAXU",$J),^TMP("DIAX",$J),^TMP($J) D CLEAN^DIEFU
 I '$G(DIAR) D  Q:$G(DIERR)
 . N %,PARAM F %=1:1:3 S PARAM=$S(%=1:$G(DIAXF)_U_"FILE",%=2:$G(DIAXSRCE)_U_"SOURCE",1:$G(DIAXT)_U_"EXTRACT TEMPLATE") I $P(PARAM,U)']"" D ERR(202,$P(PARAM,U,2))
 . Q:$G(DIERR)
 . I '$$VFILE^DIEFU(DIAXF) D ERR(202,"FILE") Q
 . I $G(DIAXSRCE) S DIAXFE=+DIAXSRCE,T="ONE"
 . I $E(DIAXSRCE)="[" S DIAXST=$P($P(DIAXSRCE,"[",2),"]"),T="DIBT"
 . D DIPT
 . Q
 E  S T="DIBT",DIAXST=DIAXSRCE
 D ^DIAXT I $G(DIERR) S:$G(DIAR) DIAR="" Q
 D @T,K
 I $G(DIERRZ) S DIERR=DIERRZ
 I $G(DIERR),$G(DIAXERRA)]"" M @DIAXERRA@("DIERR")=^TMP("DIERR",$J) K ^TMP("DIERR",$J)
 Q

DIAXU1
DIAXU1 ;SFISC/DCM-UPDATE DESTINATION FILE (CONT) ;3/5/93  2:34 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START K DIC,DO,DA,DR,DD,X
 D SETVAR,PROCESS,EOJ
 Q
 ;
SETVAR S DIAXFILE=DIAXET(DILL,"FILE")
 S DIAXMODE=$P(^TMP("DIAX",$J,DIAXFILE,"MODE"),U)
 I $D(^TMP("DIAX",$J,DIAXFILE,"X")) S X=^("X")
 I $D(^TMP("DIAX",$J,DIAXFILE,"DA(1)")) F DIAXII=1:1 Q:'$D(^("DA("_DIAXII_")"))  S @("DA("_DIAXII_")="_^("DA("_DIAXII_")"))
 I $D(^TMP("DIAX",$J,DIAXFILE,"DIC(""P"")")) S DIC("P")=^("DIC(""P"")")
 Q
 ;
PROCESS I DIAXMODE="A" S DIC=^TMP("DIAX",$J,DIAXFILE,"GL") D CALLDIC^DIAXU2 Q:$D(DIAXMSG)  S DIAXAVAL=+Y D ADDCONT Q
 D BUILDDR
 S DIE=^TMP("DIAX",$J,DIAXFILE,"GL"),@("DA="_^("DA")) I $G(DR)]"" D CALLDIE^DIAXU2 Q:$D(DIAXMSG)
 I $D(^TMP("DIAX",$J,DIAXFILE,"WP")) D WP^DIAXU2
 Q
 ;
ADDCONT S DA=DIAXAVAL,DIE=DIC
 I $D(^TMP("DIAX",$J,DIAXFILE,"WP")) D WP^DIAXU2
 D BUILDDR
 I $G(DR)]"" D CALLDIE^DIAXU2 Q:$D(DIAXMSG)
 D DA
 Q
 ;
BUILDDR I $D(^TMP("DIAX",$J,DIAXFILE,"DR")) S DR=^("DR")
 I $D(^TMP("DIAX",$J,DIAXFILE,"DR"))=11 S DIAXZRO=0 F DIAXL=0:0 S DIAXZRO=$O(^TMP("DIAX",$J,DIAXFILE,"DR",DIAXZRO)) Q:'DIAXZRO  S DR(1,DIAXFILE,DIAXZRO)=^(DIAXZRO)
 Q
 ;
DA S (DIAXET(DIAXFILE,"DA"),^TMP("DIAX",$J,DIAXFILE,"DA"))=DIAXAVAL
 S DIAXX=$G(DIAXET(DIAXFILE)) I DIAXX=""!(DIAXFILE=DIAXX) Q
 I $D(DIAXET(DIAXX,"DA")) S DIAXET(DIAXFILE,"DA(1)")=DIAXET(DIAXX,"DA")
 I $D(DIAXET(DIAXX,"DA(1)")) F DIAXII=1:1 Q:'$D(DIAXET(DIAXX,"DA("_DIAXII_")"))  S DIAXET(DIAXFILE,"DA("_(DIAXII+1)_")")=DIAXET(DIAXX,"DA("_DIAXII_")")
 Q
 ;
EOJ K DIC,DIE,DIK,DA,DR,DIAXAVAL,X,Y
 K:$D(DIAXMSG) ^TMP("DIAX",$J)
 K ^TMP("DIAX",$J,DIAXFILE,"DR"),^("WP")
 K DIAXII,DIAXFILE,DIAXMODE,DIAXDRVL,DIAXZRO,DIAXX,DIAXL,DIAX("FIELD")
 Q

DIAXU2
DIAXU2 ;SFISC/DCM-UPDATE DESTINATION FILE (CONT) ;10/13/94  10:01 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CALLDIC S DIADD=1,DIC(0)="FLI",DLAYGO=DIAXFILE
 D ^DIC I Y<1 D ERR^DIAXERR(99,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX
 K DLAYGO,DR,DINUM,DIADD,X
 Q
 ;
CALLDIE ;I DR[".01///"&($P(^DD(DIAXFILE,.01,0),U,5,99)["DINUM"!$D(^TMP("DIAX",$J,DIAXFILE,"DINUM"))) S DIAXDRVL=$P($P(DR,".01///",2),";"),DR=$P(DR,".01///"_DIAXDRVL)_$P(DR,".01///"_DIAXDRVL_";",2)
 D ^DIE I $D(Y) D ERR^DIAXERR(98,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX
 Q
 ;
WP S DIAX("FIELD")=0
 ;
WP1 S DIAX("FIELD")=$O(^TMP("DIAX",$J,DIAXFILE,"WP",DIAX("FIELD"))) Q:DIAX("FIELD")'>0
 S DKP=0
 F A9="DTL","DTO(1)","DFL","DFR(1)" S @A9=^TMP("DIAX",$J,DIAXFILE,DIAX("FIELD"),A9)
 S DTO(1)=DTO(1)_DIAXAVAL_","""_$P($P(^DD(DIAXET(DILL,"FILE"),DIAX("FIELD"),0),U,4),";")_""","
 D WORD^DITR1
 K DFR,DKP,DTO,V,A9,DFL,DTL
 G WP1
 ;
FIX I $G(^TMP("DIAX",$J,DIAXFNO,"DA")) S DA=^("DA"),DIK=^("GL") D ^DIK
 Q:DIPG
 S $P(^(0),U,7)=$P(^DIAR(1.11,DIARC,0),U,7)-1
 S:$G(DIOEND)'["DIAXU3" DIOEND=DIOEND_" D ^DIAXU3"
 K ^DIBT(DIARU,1,DIAXFE),@(DIAXF_DIAXFE_",-9)")
 Q

DIAXU3
DIAXU3 ;SFISC/DCM-EXCEPTION REPORT ;6/9/93  3:55 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 S DIPAGE=0,DIAXLINE="",DIAXX=^DIAR(1.11,DIARC,0),DIAXZ1=$P(DIAXX,U,2),DIAXZ2=$P($G(^DIC(DIAXZ1,0)),U),DIAXZ=0
 S Y=DT X ^DD("DD") S DIAXY=Y
 D HDR,BODY,END
 Q
 ;
HDR W:$Y @IOF W !,"ARCHIVAL ACTIVITY EXCEPTION REPORT",?IOM-24,DIAXY,?IOM-10,"PAGE: ",DIPAGE+1
 S DIPAGE=DIPAGE+1,$P(DIAXLINE,"-",IOM)="" W !,DIAXLINE
 Q
 ;
BODY W !!,"ARCHIVAL ACTIVITY: ",DIARC,?31,"ARCHIVER: ",$P($G(^VA(200,$P(DIAXX,U,6),0)),U)
 W !!,"THE FOLLOWING RECORDS IN THE '"_DIAXZ2_"' FILE WERE NOT MOVED BY THE EXTRACT TOOL"
 W !!?3,"INTERNAL",?16,$P(^DD(DIAXZ1,.01,0),U),!,"ENTRY NUMBER",!
 F  S DIAXZ=$O(^TMP("DIERR",$J,DIAXZ)) Q:DIAXZ'>0  W !,?5,$G(^(DIAXZ,"PARAM",2,0)),?16,$E($G(^TMP("DIERR",$J,DIAXZ,"PARAM",3,0)),1,50)
 W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
 Q
 ;
END I $E(IOST)'="C",$Y W @IOF
 D ^%ZISC
 K ^TMP("DIERR",$J),DIAXY,DIAXLINE,DIPAGE,DIAXX,DIAXZ,DIAXZZ,DIR,DIRUT,DTOUT,DUOUT,DIAXZ1,DIAXZ2
 Q
 ;
HDRC Q:($Y+1<IOSL)
 I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT))
 D HDR
 Q
 ;

DIB
DIB ;SFISC/GFT,XAK-CREATE A NEW FILE ;7/8/94  14:42
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W !! K DLAYGO,DTOUT D W^DICRW G Q:$D(DTOUT) K DICS,DIA Q:Y<0
1 Q:'$D(@(DIC_"0)"))  I $P($G(^DD(+$P(@(DIC_"0)"),U,2),0,"DI")),U,2)["Y" W !!,$C(7),"RESTRICTED"_$S($P(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE - NO EDITING ALLOWED!" Q
 S:$D(@(DIC_"0)")) DIA=DIC,X=^(0),(DI,J(0),DIA("P"))=+$P(X,U,2)
 D QQ S DR="",(L,DRS,DIAP,DB,DSC)=0,F=-1,I(0)=DIA,DXS=1
 D EN^DIA:$O(^DD(DI,.01))>0 I $D(DR) G ^DIA2
Q K DI,DLAYGO,DIA,I,J
QQ K ^UTILITY($J),DIAT,DIAB,DIZ,DIAO,DIAP,DIAA,IOP,DSC,DHIT,DRS,DIE,DR,DA,DG,DIC,F,DP,DQ,DV,DB,DW,D,X,Y,L,DIZZ Q
 ;
DIE ;
 S F=+Y,(DG,X)="^DIZ("_F_","
 I DUZ(0)="@" W !!,"INTERNAL GLOBAL REFERENCE: "_DG R "// ",X:DTIME S:'$T X="^" S:X="" X=DG I X?."?" W !,"TYPE A GLOBAL NAME, LIKE '^GLOBAL(' OR '^GLOBAL(4,'",!,"OR JUST HIT 'RETURN' TO STORE DATA IN '"_DG_"'" G DIE
 I X?1"^".E S X=$P(X,U,2,9) I X?.P W !?9,$C(7),"NO NEW FILE CREATED!" S DIK="^DIC(",DA=F K DG G ^DIK
 I "(,"[$E(X,$L(X)),X?1A.E!(X?1"%".E)!(X?1"[".E1"]"1AP.E) S DG=U_X,@("%=$O("_DG_"0))=""""") G SET:% W !,$C(7),"WARNING -- "_DG_" ALREADY EXISTS!  " G SET:DUZ(0)'="@" W "--OK" D YN^DICN G SET:%=1
 W $C(7),"??" G DIE
SET D WAIT^DICD S $P(^DIC(F,0),U,2)=F,^("%A")=DUZ_U_DT,X=$P(^(0),U,1),^(0,"GL")=DG
 I DUZ(0)]"" F %="DD","DEL","RD","WR","LAYGO","AUDIT" S ^(%)=DUZ(0)
 I DUZ(0)'="@",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D SET1
 S %="" I @("$D("_DG_"0))") S %=^(0)
 S @(DG_"0)=X_U_F_U_$P(%,U,3,9)")
 K ^DD(F) S ^(F,0)="FIELD^^.01^1",^DD(F,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X"
 S ^(3)="NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION" W !?5,"A FreeText NAME Field (#.01) has been created."
 S DA="B",^DD(F,.01,1,0)="^.1",^(1,0)=F_U_DA,X=DG_""""_DA_""",$E(X,1,30),DA)",^(1)="S "_X_"=""""",^(2)="K "_X
 S DIK="^DIC(",DA=F D IX1^DIK
 S DLAYGO=F,DIK="^DD(DLAYGO,",DA=.01,DA(1)=DLAYGO G IX1^DIK
 ;
EN ; Enter here when the user is allowed to select his fields
 S DIC=DIE S:DIC DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"")
 D 1:DIC]"" K DIC Q
 ;
SET1 ;
 S:'$D(^VA(200,DUZ,"FOF",0)) ^(0)="^200.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1"
 S:'$D(^DIC(3,DUZ,"FOF",0)) ^(0)="^3.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1"
 S DIK=$S($D(^VA(200)):"^VA(200,DUZ,""FOF"",",1:"^DIC(3,DUZ,""FOF"","),DA=F,DA(1)=DUZ D IX1^DIK
 Q

DIBT
DIBT ;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;9/7/95  09:27
 ;;21.0;VA FileMan;**2,16**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 ;
 S DIC="^DOPT(""DIBT""," G 1:$D(^DOPT("DIBT",.402)) S ^(0)="TEMPLATE FILE^1.01" K ^("B") F X=.4,.401,.402 S ^DOPT("DIBT",X,0)=$P("PRINT^SORT^INPUT",U,$E(X,4)+1)_" TEMPLATE"
 S DIK=DIC D IXALL^DIK
1 ;
 S DICF=DI,DIC(0)="QEAIN" D ^DIC K DIC Q:Y<0  S DIC=+Y
11 W !! Q:$D(DTOUT)  S DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF
 S DIC(0)="AEQI" D IX^DIC I Y<0 K DIC,DICF Q
 S DA=+Y,DIE=DIC,DR=".01:3;5:7;10;707;491620",DIOVRD=1 D ^DIE K DR,DIOVRD G 11
 ;
S ;
 D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT))
 G N:X="",S:Y<0
 S DIBT1=+Y
SNEW K ^DIBT(DIBT1,2) S $P(^DIBT(DIBT1,0),U,7)=DT
 S (DIBT2,DIBT3)=0 F  S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3  S DIBT2=DIBT2+1 D
 .N DIC,DA,DIE,DINUM,DIOVRD,DR S X=$P(DPP(DIBT3),U) Q:+$P(X,"E")'=X  S DIC="^DIBT("_DIBT1_",2,",DIC(0)="L",DA(1)=DIBT1,DINUM=DIBT2,DIOVRD=1,DIC("P")=$P(^DD(.401,1621,0),U,2) D FILE^DICN K DIC,DA,DINUM,DIOVRD
 .N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10)
 .S A="A" F  S A=$O(DPP(DIBT3,A)) Q:A=""  S %=$G(DPP(DIBT3,A)) S:%]"" ^DIBT(DIBT1,2,DIBT2,A)=%
 .S (C,D)=0 F A=-1:0 S A=$O(DPP(DIBT3,A)) Q:+$P(A,"E")'=A  D
 ..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM
 ..S B="" F  S B=$O(DPP(DIBT3,A,B)) Q:B=""  S D=D+1,%=2,%(1)=18,X=A,DINUM=D D DICM S:Y>0 ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$P(DPP(DIBT3,A,B),U,4,99)
 ..Q
 .S D=0,A="OV" F  S A=$O(DPP(DIBT3,A)) Q:$E(A,1,2)'="OV"  S B="" F  S B=$O(DPP(DIBT3,A,B)) Q:B=""  S C=$G(DPP(DIBT3,A,B)) I C]"" S D=D+1,%=3,%(1)=19,X=A,DINUM=D D DICM I Y>0 S $P(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B,^("OVF0")=C
 .Q
 I $D(DIBTOLD) K DIBTOLD D K Q
 S DIBT2=0
S0 S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B"
 S DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and",DIR("?")="ending sort values when the print job is run."
 W ! S DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$P(DPP(DIBT2),U,3)_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) D K G Q^DIP
 G:Y=0 S0
S1 S ^DIBT(DIBT1,2,DIBT2,"ASK")=1
 G S0
 ;
DICM S DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_",",DA(2)=DIBT1,DA(1)=DIBT2,DIC(0)="L",DIOVRD=1,DIC("P")=$P(^DD(.4014,%(1),0),U,2)
 N C,D
 I %(1)=18 S DIC("DR")="1////"_B F C=1,2,3 S D=$P(DPP(DIBT3,A,B),U,C) I D]"" S DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D
 N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q
 ;
US S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q
 N %,A S X=+$G(DPP(0)),A=0 F X=X:0 S X=$O(DPP(X)) Q:'X  S A=A+1 D
 .F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT" S:$D(DPP(X,%)) ^DIBT(DIBT1,2,A,%)=DPP(X,%)
 .K ^DIBT(DIBT1,2,A,"SER") Q
 Q
 ;
K K DIEDT,DIBT2,DIBT3 Q
N D K G N^DIP1

DIBT1
DIBT1 ;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;8/2/94  15:57
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
S1 K DIR S DIR(0)="O",DIR("A")="STORE IN 'SORT' TEMPLATE",DIR("?")="^D H1^DIBT1"
 D SAV Q:$D(DIRUT)  D DIC Q
 ;
S2 K DIR S DIR(0)="O",DIR("A")="STORE THESE ENTRY ID'S IN TEMPLATE",DIR("?")="^D H2^DIBT1"
 D SAV Q:$D(DIRUT)  D MRG Q
 ;
S3 K DIR S DIR(0)="O",DIR("A")="STORE RESULTS OF SEARCH IN TEMPLATE",DIR("?")="^D H3^DIBT1"
 S:$D(DIAR) DIR(0)=""
 D SAV Q:$D(DIRUT)  D MRG Q
 ;
SAV S DIR(0)="F"_DIR(0)_"^1,30"
 D ^DIR K DIR Q:$D(DIRUT)
 I $E(X)="[" S X=$P($E(X,2,99),"]",1)
 Q
H1 N A,B S A="sort criteria",B="SORT" D H,DIC Q
H2 N A,B S A="list of entries",B="SEARCH/SORT" D H,MRG Q
H3 N A,B S A="list of entries from the search",B="SEARCH/SORT"
 W:$D(DIAR) !!,"You must store the results in a template.",!,"Otherwise you will have to rerun this search to archive the entries."
 D H,MRG Q
H W !!,"If you wish to save this "_A_" for later re-use",!,"enter the name of a "_B_" TEMPLATE here (1-30 characters)." Q
MRG ;
 S DIBT1=1
DIC K DIC S DIC="^DIBT(",DLAYGO=0,DIC(0)="QELSZ",DIOVRD=1,DIC("S")="I "_$S($D(DIAR)&('$D(DIARI)):"",1:"'")_"$P(^(0),U,8)"
 S DIC("S")=DIC("S")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5)!$D(DIEDT)",D="F"_DK
 D IX^DIC S DIBTY=Y K DIC,DLAYGO,DIEDT,DIOVRD G QDIC:Y'>0
 N X,DIBTSEC S DIBTSEC="" I $O(^DIBT(+Y,0))]"" S DIBTSEC=Y(0) D ALR
 I $D(DIRUT)!(Y'>0) G QDIC
 D NOW^%DTC
 S ^DIBT("F"_DK,$P(Y,U,2),+Y)=1,^DIBT(+Y,0)=$P(Y,U,2)_U_+$J(%,0,4)_U_$S(DIBTSEC]"":$P(DIBTSEC,U,3),1:DUZ(0))_U_DK_U_DUZ_U_$S(DIBTSEC]"":$P(DIBTSEC,U,6),1:DUZ(0)) I $D(DIAR),'$D(DIARI) S $P(^(0),U,8)=1
 K DIBTSEC N DIE,DA,DI,DK,DR,Y S DIE="^DIBT(",DA=+DIBTY,DR=10,DIOVRD=1 D ^DIE K DUOUT,DIROUT,DIRUT
QDIC K DIBT1,DIBTY,DIOVRD,%,%X,%Y Q
ALR W !,$C(7) I $D(DIBT),+Y=DIBT W "NO!! YOU ARE USING THAT TEMPLATE FOR YOUR LIST OF ENTRIES!" S Y=-1 Q
 I $D(DISV),+Y=DISV W "NO!! YOU ARE GOING TO STORE SEARCH RESULTS IN THAT TEMPLATE!" S Y=-1 Q
 N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="DATA ALREADY STORED THERE....OK TO PURGE" D ^DIR Q:$D(DIRUT)
 I Y=1 S %Y="" D  S Y=DIBTY Q
 .F  S %Y=$O(^DIBT(+DIBTY,%Y)) Q:%Y=""  I %Y'="%D",%Y'="ROU",%Y'="ROUOLD",%Y'="DIPT" K ^DIBT(+DIBTY,%Y)
 .Q
 S %Y=-1 I $O(^DIBT(+DIBTY,1,0))'>0!'$D(DIBT1) S Y=-1 Q
 F %=0:0 S %=$O(^(%)),%Y=%Y+1 Q:%'>0
 K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="WANT TO MERGE THESE ENTRIES",DIR("A")="WITH THE "_%Y_" ALREADY IN '"_$P(DIBTY,U,2)_"' TEMPLATE"
 D ^DIR S Y=$S(Y=0:-1,1:DIBTY) W ! Q

DIC
DIC ;SFISC/XAK,SEA/TOAD-VA FileMan: Lookup, Part 1 ;5/8/96  14:54
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12017;9887383;4339;
 
 N D
 S D="B" K DF,DS,DIROUT,DTOUT,DUOUT
EN K DO,DICR S U="^" S:DIC DIC=^DIC(DIC,0,"GL") D PGM^DIC2 I $D(DIPGM) S DIPGM(0)=1 G @DIPGM
 I '$D(@(DIC_"0)")),'$D(DIC("P")),$E(DIC,1,6)'="^DOPT(" S Y=-1 G Q^DIC2
ASK I DIC(0)["A" W ! D ^DIC1
 I $D(DIADD),X'["""",U'[X,X'?."?" S X=""""_X_""""
X ;
 D DO^DIC1:'$D(DO) I U'[X,X'?."?",$D(^DD(+DO(2),.01,7.5)) X ^(7.5) G:'$D(X) BAD^DIC1
 D PGM^DIC2 I $D(DIPGM) S DIPGM(0)=2 G @DIPGM
RTN D:'$D(DO) DO^DIC1
 G O^DIC1:X'?.ANP,N:$L(X)>30
 I X?.NP G NO:X="",N:U[X,NUM:+X=X&(X>0),^DICQ:X?1."?" I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC))#2 S Y=+^(DIC) D S G GOT^DIC2:$T,BAD^DIC1
F ;
 S (DD,DS)=0
T S Y=$O(@(DIC_"D,X,0)")),DIX=X S:Y="" Y=-1 I Y'<0 G DIY:$O(^(Y))]""!((DIC(0)'["O")&(DIC(0)["E")) D MN I  G K:DS S DS=1 G GOT^DIC2
DIX I DIC(0)'["X" S:X?.N&(DO(2)'["D")&'$D(DIDA) DIX=$O(@(DIC_"D,DIX_"" "")"),-1) S DIX=$O(@(DIC_"D,DIX)")) I $P(DIX,X)="",DIX'="" S Y=$O(^(DIX,0)) S:Y="" Y=-1 G DIY
M I DIC(0)["M" S D=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) S:$D(DID) DID(1)=DID(1)+1
 I DIC(0)["M",D]"" G M:$D(@(DIC_"D)"))-10,T:X'?.NP,T:+X'=X D DO^DIC1:'$D(DO) S Y=$O(^DD(+DO(2),0,"IX",D,0)) S:Y="" Y=-1 G T:$O(^(Y,0))="",T:'$D(^DD(Y,$O(^(0)),0)),M:$P(^(0),U,2)["P",T
 D D G G:DS=1,Y^DIC1:DS
N I X[U S DUOUT=1 G NO
 D DO^DIC1:'$D(DO) I X?1"`".NP S Y=$E(X,2,30),DZ=0 G A:Y="" D S S DS=1,DD=Y G GOT^DIC2:$T I DIC(0)'["L" W:DIC(0)["Q" $C(7),$S('$D(DDS):"  ??",1:"") G A
 G ^DICQ:X?."?",^DICM
NUM D DO^DIC1:'$D(DO) G F:DO(2)<0!$D(DF) S DD=$D(^DD(+DO(2),.001)),DS=$P(^(.01,0),"^",2) I $D(@(DIC_"X)")) G:'DD P:DS["N"!('$O(^("A["))&($O(^("A["))]"")) S Y=X D S G GOT^DIC2:$T
P I DS["P"!(DS["V"),DIC(0)'["U" S (DD,DS)=0 G M
 G F
1 ;
 D S G GOT^DIC2:$T,F
MN S DZ=$S(DIC(0)["D":1,$D(^(Y))-1:0,1:^(Y)),DIYX=0 D:'$D(DO) DO^DIC1
 I 'DZ,'$D(DO("SCR")),$L(DIX)<30,D="B",'$D(DIC("S")),'$D(@(DIC_"Y,-9)")) S DIY="" Q
 D S S:D="B"&'DZ&($P(DIY,DIX)="") DIY=$P(DIY,DIX,2,9),DIYX=1
 Q
S D:'$D(DO) DO^DIC1 I $D(@(DIC_"Y,0)")) S DIY=$P(^(0),U)
 E  S DIY="" Q
 I '$D(^(-9)) X:$D(DIC("S")) DIC("S") K DIAC,DIFILE Q:'$T!'$D(DO("SCR"))  I $D(@(DIC_"Y,0)")) X DO("SCR")
 Q
Y S Y=$O(@(DIC_"D,DIX,Y)")) S:Y="" Y=-1
DIY I Y<0 G DIX:DIC(0)'["O"&(DIC(0)["E"),G:DS=1&(D="B")&(DIX=X),DIX
 D MN E  G Y
K F DZ=1:1:DS I $D(DS(DZ)),+DS(DZ)=Y,DIC(0)'["C" G Y
 D DS^DICN1:'$D(DISMN) I $S<DISMN F DZ=1:1:DS-7 K DS(DZ),DIY(DZ),DIYX(DZ)
 S DS=DS+1,DS(DS)=Y_"^"_$P(DIX,X,2,99),DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 G Y:DS#5-1,Y:DS=1,Y:DIC(0)["Y",Y^DIC1
G S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["D",'$D(DICRS) S:$D(DDS) DST=$S($D(DST)#2:DST_"  ",1:"")_X_$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"") W:'$D(DDS) $P(DS(1),U,2,99)
C S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIYX=$G(DIYX(DIY)),DIY=DIY(DIY)
 G GOT^DIC2
 ;
D S D=$S($D(DF):DF,1:"B") S:$D(DID(1)) DID(1)=2 Q
IX K DTOUT,DUOUT S DF=D G EN
A K DIY,DIYX,DS I DIC(0)["A" D D G ASK
NO S Y=-1 G Q^DIC2
 ;
 ;DBS entry points
 ;
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DICALSCR,DIWRITE,DILIST,DIMSGA) ;SEA/TOAD
 ;ENTRY POINT--return a list of entries from a file
 ;subroutine, DIFROM passed by value
 G IN^DICL
 
FIND1(DIFILE,DIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIMSGA) ;SEA/TOAD
 ;ENTRY POINT--find a single entry in the file
 ;function, all passed by value
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
 N DIERN,DIFIND,DIPE,DITARGET
 D FIND^DICF($G(DIFILE),$G(DIEN),"",$G(DIFLAGS)_"f",$G(DIVALUE),1,$G(DINDEX),$G(DISCREEN),"","DITARGET")
 I $D(DIERR) S DIFIND=""
 E  I $P($G(DITARGET(0)),U,3) K DITARGET S DIFIND="" D
 .S DIERN=299
 .S DIPE(1)=$G(DIVALUE)
F1 .S DIPE("FILE")=$G(DIFILE)
 .S DIPE("IEN")=$G(DIEN)
 .D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 .Q
 E  S DIFIND=+$G(DITARGET(1))
 I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
 Q DIFIND
 
FIND(DIFILE,DIEN,DIFLDS,DIFLAGS,DIVALUE,DIMAX,DIFORCE,DISCREEN,DID,DILIST,DIMSGA) ;SEA/TOAD
 ;ENTRY POINT--in a file find entries that match a value
 ;procedure, all passed by value
 G FINDX^DICF
 ;

DIC1
DIC1 ;SFISC/GFT-READ X, SHOW CHOICES ;09:14 AM  7 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DUOUT,DTOUT I $D(DIC("A")) S DD=DIC("A") G B
 D DO S Y=$P(DO,U) I D="B",DO(2)>1.9 S X=$P(^DD(+DO(2),.01,0),U) I X'[Y,Y'[X S Y=Y_" "_X
 S DD=$$EZBLD^DIALOG(8042,Y)
B I $D(DIC("B")),DIC("B")]"" S Y=DIC("B"),X=$O(@(DIC_"D,Y)")),DIY=$S($D(^(Y)):Y,$F(X,Y)-1=$L(Y):X,$D(@(DIC_"Y,0)")):$P(^(0),U),1:Y) W DD D WR^DIC2 R "// ",X:$S($D(DTIME):DTIME,1:300) G T:'$T,DO:X]"" S X=DIY S:DIC(0)'["O" DIC(0)=DIC(0)_"O" G DO
 W DD R X:$S($D(DTIME):DTIME,1:300) E  G T
DO ; GET FILE ATTR
 Q:$D(DO)  I $D(@(DIC_"0)")) S DO=^(0)
 E  S DO="0^-1" I $D(DIC("P")) S DO=U_DIC("P"),^(0)=DO
DO2 S DO(2)=$P(DO,U,2) I DO?1"^".E S DO=$O(^DD(+DO(2),0,"NM",0))_DO
 I DO(2)["s",$D(^DD(+DO(2),0,"SCR")) S DO("SCR")=^("SCR")
 Q:DO(2)'["I"!$D(DIC("W"))  Q:'$D(^DD(+DO(2),0,"ID"))  S %=0,DIC("W")="" I DO(2)["P" D WOV S %=+DO(2),%Y=DIC G P
W ;
 S %=$O(^DD(+DO(2),0,"ID",%)) I %]"" G WOV:$L(DIC("W"))+$L(^(%))>224 S:^(%)'="W """"" DIC("W")=DIC("W")_" W ""   "" "_^(%) G W
 S DIC("W")=$E(DIC("W"),2,999) Q
P I %,$D(^DD(%,.01,0)) S %=+$P($P(^(0),U,2),"P",2) I $D(^DIC(%,0,"GL")) S %W=^("GL") D Q:%W]"" G P
 Q
Q S %W1=%W
 I %W[$C(34) S %W1=$P(%W,$C(34))_$C(34,34)_$P(%W,$C(34),2)_$C(34,34)_$P(%W,$C(34),3,9)
 I $L(DIC("W"))<200 S DIC("W")=DIC("W")_" I '$D(DICR) S %Y=+"_%Y_"%Y,0) I $D("_%W_"%Y,0)) S %W="_%_",%Z="""_%W1_""" D WOV^DICQ1",%Y=%W
 K %W1 Q
WOV S DIC("W")="S %W=+DO(2),%Y=Y,%Z=DIC D WOV^DICQ1" Q
 ;
RENUM ;
 D DO I '$D(DF),X?.NP,^DD(+DO(2),.01,0)["DINUM",$D(@(DIC_"X)")) S Y=X G 1^DIC
 G F^DIC
 ;
DT S DST=DST_$$FMTE^DILIBF(%,"7S")
 I '$D(DDS) W DST S DST=""
 Q
Y ;
 S DZ=Y,DD=$O(DS(DD)),DDH=DD-1,Y=+DS(DD),DIYX=0
 I DIC(0)["E" W:'$D(DDS) !?5,DD,?9 D E
 S Y=DZ I DIC(0)["Y" G Y:DD<DS F Y=DS:-1 G Q^DIC2:'Y S Y(+DS(Y))=""
 G N:DIC(0)'["E" I DS>DD G Y:DD#5 W:'$D(DDS) !,"TYPE '^' TO STOP, OR"
 I $D(DDS) S DDD=2,DDC=5 D LIST^DDSU K DDD,DDC I $D(DTOUT) D T G N
 I '$D(DDS) W !,"CHOOSE "_$O(DS(0))_"-"_DD R ": ",DIY:$S($D(DTIME):DTIME,1:300) E  D T G N
 I DIY=""!(U[DIY)!$D(DUOUT) S:DIY=U DUOUT=1 G:DD=DS L^DICM:DO(2)["O"&(DO(2)'["A"),A^DIC G Y^DIC:DIY="" S X=U G A^DIC
 I DIY?1."?" S DIC1Q=1 I DIC(0)_$G(DICR(1,0))'["A" D
 . S DIY=X I '$D(DICRS) N DIY,X,D,DZ S D=$S($D(DF):DF,1:"B"),DZ="?" D DQ^DICQ
 I DIY'?1.N&'$D(DICRS)!$D(DIC1Q) S D=$S($D(DF):DF,1:"B"),X=DIY K DIC1Q,DIY,DS,DDH("ID") G X^DIC
 G BAD:'$D(DS(DIY)) S Y=+DS(DIY) K DIC("W"),DIVP1
 S:$D(DDS) DST=X_$P(DS(DIY),U,2,9)_$S($G(DIYX(DIY)):$G(DIY(DIY)),1:"")
 G C^DIC
 ;
E S DST=""
 S %=$P(X,U,'$D(DICRS))_$P(DS(DD),U,2,9),DIY=$S(%=DIY(DD):"",DO(2)["D"&($D(DIDA)!(DIY(DD)="")):%,1:"")_DIY(DD)
 S:DO(2)'["D"&'$D(DIDA) DST=DST_%
 S:$G(DIYX(DD)) DST=DST_DIY(DD),DIY=""
 D DT:D'="B"&$D(DIDA),WO^DIC2
 Q
 ;
T W $C(7) S X="",DTOUT=1 Q
OK ;
 S %=1 I $D(DS),DS=1 S DST="         ...OK" D Y^DICN
 I %>0 G R^DIC2:%=1 S X=DIX G L^DICM
O ;
BAD I DIC(0)["Q" D
 . W:'$D(DUOUT) $C(7)_$S('$D(DDS):" ??",1:"")
 . I $D(Y),Y[U S Y=-1
 Q:$D(DTOUT)  G A^DIC
N G NO^DIC
MIX ;
 S DID=D_"^-1",DID(1)=2,D=$P(DID,U) G IX^DIC
 ;
 ;#8042  Select |filename|:

DIC2
DIC2 ;SF/XAK-LOOKUP (CONT) ;11/6/92  8:39 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
WO S DST=$G(DST)_"  " D WR I $D(DIC("W")),$D(@(DIC_"Y,0)")) D:$D(DDS)&'$D(DDH("ID")) ID^DICQ1 I '$D(DDS) W $G(DST),"  " X DIC("W") K DST
 Q
WR D:'$D(DO) DO^DIC1 I DIC(0)["S",X'=" " Q:"  "[$G(DST)  G S
 S DST=$G(DST)
 I DO(2)["V" S %X=Y,DIYS=DIY D NAME^DICM2 S Y=%X,DIY=DIYS,DST=DST_DINAME K DINAME,%X G S
 I DIY'?1.N.1".".N G W1
 I DO(2)["D" S %=DIY D DT^DIC1 G S
 I DO(2)["P",$D(@("^"_$P(^DD(+DO(2),.01,0),"^",3)_+DIY_",0)")) S %X=Y,Y=DIY,C=$P(^DD(+DO(2),.01,0),U,2) D Y^DIQ S DST=DST_Y,Y=%X G S
W1 S:'$G(DIYX) DST=DST_DIY
S S A1=Y I '$D(DDS) W DST K DST,A1 Q
H S:'$D(A1) A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K DST,A1 Q
 ;
PGM K DIPGM I DIC(0)'["I",'$D(DF),$D(@(DIC_"0)")),$D(^DD(+$P(^(0),U,2),0,"DIC"))#2,^("DIC")'?1"DI".E S DIPGM=U_^("DIC")
 Q
 ;
GOT I DIC(0)["E" D WO I $D(DDS),$D(DDH)>10 D LIST^DDSU K DDH("ID")
 S Y=Y_"^"_$S(DIY="":X,$G(DIYX):X_DIY,1:DIY) I DIC(0)["E",DO(2)["O" G OK^DIC1
R D:'$D(DICR) ACT^DICM1 G A^DIC:Y<0
 I DIC(0)["Z" K D S:$D(C)#2 D=C S Y(0)=@(DIC_"+Y,0)"),C=$P(^DD(+DO(2),.01,0),U,2),DS=Y,Y=$P(Y(0),U) D Y^DIQ S Y(0,0)=Y,Y=DS,Y(0)=@(DIC_"+Y,0)") S:$D(D) C=D
ACT I DIC(0)'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y
 I $D(@(DIC_"+Y,0)"))
Q K DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE
 K:'$G(DICR) DIC("W")
 Q

DICA
DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;5/9/96  12:44
 ;;21.0;VA FileMan;**6,17,8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12020;5157184;4602;
 
ADD(DIFLAGS,DIFDA,DIEN,DIMSGA) 
 
ADDX ; Branch in from UPDATE^DIE
 ; ENTRY POINT--add a new entry to a file
 ; subroutine, DIEN passed by reference
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
 K ^TMP("DIADD",$J)
INPUT 
 ; initialize input parameters & check
 N DIRULE S DIRULE="^TMP(""DICA"",$J)"
 N DIFDAO
 S DIFLAGS=$G(DIFLAGS)
 I $TR(DIFLAGS,"ESY")'="" D  Q
 . D ERR^DICA3(301,"","","",DIFLAGS),CLOSE
 S DIFDA=$G(DIFDA) I $D(@DIFDA)<10 D  Q
 . D ERR^DICA3(202,"","","","FDA"),CLOSE
 S DIFDAO=DIFDA
 S DIEN=$G(DIEN) I DIEN="" S DIEN="DIDUMMY" N DIDUMMY
PRE 
 N DIOK S DIOK=1 D CHECK^DICA1(DIFLAGS,.DIFDA,DIEN,DIRULE,.DIOK)
 I $G(DIERR) D CLOSE Q
 I 'DIOK D ERR^DICA3(202,"","","","FDA"),CLOSE Q
SEQ 
 N DIENTRY,DIFILE,DIOUT1,DINEXT
 S (DIOUT1,DINEXT)="" F  D  Q:DIOUT1
 . S DINEXT=$O(@DIRULE@("NEXT",DINEXT)) I DINEXT="" S DIOUT1=1 Q
 . X @DIRULE@("NEXT",DINEXT)
FILES .
 . I $P($G(^DD($$FNO^DILIBF(DIFILE),0,"DI")),U,2)["Y" D  Q:DIOUT1
 . . S DIOUT1=DIFLAGS'["Y"&'$D(DIOVRD)
 . . I DIOUT1 D ERR^DICA3(405,DIFILE,"","",DIFILE)
ENTRIES .
 . N DIDA,DIENP,DIOP,DIROOT,DISEQ
 . S DIDA=$P(DIENTRY,",") I +DIDA=DIDA Q
 . S DIENP=$$IEN(DIENTRY,"",DIRULE)
 . S DIOP=$E(DIDA,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
 . S DISEQ=$P(DIDA,DIOP,2)
FINDING .
 . I DIOP["?" S DIOUT2=0 D  I DIOUT2 Q
 . . N DIFIND,DIFORMAT,DIGET,DIVALUE
 . . S DIFORMAT=$S(DIFLAGS["E":"",1:"Q")_$S(DIOP="?+":"X",1:"")
 . . S DIGET=DIFDA
 . . I DIFLAGS["E",DIOP="?" S DIGET=DIFDAO
 . . S DIVALUE=$G(@DIGET@(DIFILE,DIENTRY,.01))
 . . S DIFIND=$$FIND1^DIC(DIFILE,DIENP,DIFORMAT,DIVALUE)
 . . I $G(DIERR) S DIOUT1=1,DIOUT2=1 Q
 . . I DIOP="?+",'DIFIND Q
 . . I 'DIFIND S DIOUT1=1,DIOUT2=1 D  Q
 . . . D ERR^DICA3(703,DIFILE,DIENTRY,"",DIVALUE)
 . . S @DIEN@(DISEQ)=DIFIND
 . . S @DIRULE@("IEN",DISEQ)=DIFIND
 . . D SAVE S DIOUT2=1
ADDING .
 . N DIENEW,DIKEY
 . I $L(DIENP,",")>2 S DIOK=$$VMINUS9^DIEFU(DIFILE,DIENP) I 'DIOK D  Q
 . . S DIOUT1=1
 . . D ERR^DICA3(602,DIFILE,$P(DIENP,",",$L(DIENP,",")-1))
 . S DIROOT=$$ROOT^DIQGU(DIFILE,DIENP)
 . D DA^DILF(DIENTRY,.DIENEW)
A1 . S DIENEW=$$IEN(DIENTRY,$G(@DIEN@(DISEQ)),DIRULE)
 . S DIKEY=$G(@DIFDA@(DIFILE,DIENTRY,.01)) I DIKEY="" D  Q
 . . S DIOUT1=1 D ERR^DICA3(202,"","","","FDA")
 . S DIOK=$$LAYGO(DIFILE,.DIENEW,DIKEY)
 . I 'DIOK S DIOUT1=1 D  Q
 . . I '$G(DIERR) D ERR^DICA3(405,DIFILE,"","",DIFILE) Q
 . . N DIENS S DIENS="New entry"
 . . I $L(DIENEW,",")>2 S DIENS=DIENS_" under record: "_DIENEW
 . . N DI1 S DI1="LAYGO Node on the new value '"_DIKEY_"'"
 . . D ERR^DICA3(120,DIFILE,DIENS,.01,DI1)
 . D CREATE^DICA3(DIFILE,.DIENEW,DIROOT,DIKEY)
 . S DIENEW=+DIENEW
 . I 'DIENEW S DIOUT1=1 Q
 . L -@(DIROOT_"DIENEW)")
 . S @DIEN@(DISEQ)=DIENEW
 . S @DIRULE@("IEN",DISEQ)=DIENEW
 . D SAVE
 
FILER ; file the data for the new records
 I '$G(DIERR),$D(@DIFDA) D
 . D FILE^DIEF($S(DIFLAGS["S":"S",1:""),DIFDA,"",DIEN)
 I '$G(DIERR),DIFLAGS'["S" K @DIFDAO
 I $G(DIERR)!(DIFLAGS["S"),DIFLAGS'["E" D
 . M @DIFDA=^TMP("DIADD",$J) K ^TMP("DIADD",$J)
 D CLOSE
 Q
 
LAYGO(DIFILE,DIEN,DIKEY) 
 ; ADDING--return if LAYGO permitted
 ; function, all by value
 N DA,DIOK,DINODE,DIOUTS,X,Y,Y1
 S DIOK=1,DINODE="",DIOUTS=0 F  D  I DIOUTS!'DIOK Q
 . S DINODE=$O(^DD(DIFILE,.01,"LAYGO",DINODE))
 . I DINODE'>0 S DIOUTS=1 Q
 . I $D(^DD(DIFILE,.01,"LAYGO",DINODE,0))[0 Q
 . S X=DIKEY M DA=DIEN S Y=$P(DA,","),Y1=DA,DA=$P(DA,",")
 . I 1 X ^DD(DIFILE,.01,"LAYGO",DINODE,0) S DIOK=$T&'$G(DIERR)
 Q DIOK
 
SAVE I DIFLAGS'["E" D
 . S ^TMP("DIADD",$J,DIFILE,DIENTRY,.01)=@DIFDA@(DIFILE,DIENTRY,.01)
 K @DIFDA@(DIFILE,DIENTRY,.01)
 Q
 
IEN(DIENTRY,DIENF,DIRULE) 
 ; ADDING/FINDING--return translated IEN String
 ; function, DIENTRY passed by value
 N DIC,DIENEW,DIOP,DIP,DIPNEW,DISEQ
 S DIENEW=""
 S DIENF=$G(DIENF)
 S DIP="" F DIC=1:1 D  I DIP="" Q
 . S DIP=$P(DIENTRY,",",DIC) I DIP="" Q
 . D
 . . I +DIP=DIP S DIPNEW=DIP Q
IEN1 . . I DIC=1 S DIPNEW=DIENF Q
 . . S DIOP=$E(DIP,1,2) I DIOP'="?+" S DIOP=$E(DIOP)
 . . S DISEQ=$P(DIP,DIOP,2,9999)
 . . S DIPNEW=@DIRULE@("IEN",DISEQ)
 . S $P(DIENEW,",",DIC)=DIPNEW
 I DIENEW'="" S DIENEW=DIENEW_","
 Q DIENEW
 
CLOSE I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
 K @DIRULE
 Q

DICA1
DICA1 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor ;3/23/95  14:21 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11758;4597954;
 
CHECK(DIFLAGS,DIFDA,DINUMS,DIRULE,DIOK) 
 ; ENTRY POINT--check out the FDA
 ; subroutine, DIFLAGS passed by value
 N DIC,DIEN,DIFILE,DIFLD,DIN,DINODE,DINT,DINUM,DIOP
 N DIOUT1,DIOUT2,DIOUT3,DIRID,DIRIGHT,DISEQ,DITYPE,DIVAL
FILES 
 S DIFILE=0,DIOUT1=0 F  D  Q:DIOUT1!$G(DIERR)
 . S DIFILE=$O(@DIFDA@(DIFILE))
 . I 'DIFILE S DIOUT1=1 Q
 . S DINODE=$G(^DD(DIFILE,.01,0))
 . I DINODE="" D  Q
 . . D ERR^DICA3($S('$D(^DD(DIFILE)):401,1:406),DIFILE)
 . I $P(DINODE,U,2)["W" D  Q
 . . D ERR^DICA3(407,DIFILE)
 . S DIRID=$$RID^DICU(DIFILE)
IENS .
 . S DIEN="",DIOUT2=0 F  D  Q:DIOUT2!$G(DIERR)
 . . S DIEN=$O(@DIFDA@(DIFILE,DIEN))
 . . I DIEN="" S DIOUT2=1 Q
 . . N DIDA D IEN^DICA2(.DIFILE,DIEN,.DIDA,DIRULE,.DIOK) Q:$G(DIERR)
 . . I 'DIOK S DIOUT1=1,DIOUT2=1 D  Q
 . . . I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q
 . . . D ERR^DICA3(202,"","","","IENS")
 . . S DIOK=$$RID(DIFILE,DIEN,DIFDA,DIRID)
 . . I 'DIOK D  Q
 . . . I $P(DIEN,U)["+" D ERR^DICA3(311,"",DIEN) Q
 . . . I $E(DIEN)="?",$P(DIOK,U,2)=".01" D ERR^DICA3(351,DIFILE,DIEN) Q
 . . . D ERR712(DIFILE,$P(DIOK,U,2)) Q
 . . I $D(@DIFDA@(DIFILE,DIEN,.001))#2 D
 . . . N DIENS S DIENS=@DIFDA@(DIFILE,DIEN,.001)
 . . . I $D(@DINUMS@(@DIRULE@("NUM")))[0 D
 . . . . S @DINUMS@(@DIRULE@("NUM"))=DIENS
 . . . S ^TMP("DIADD",$J,DIFILE,DIEN,.001)=DIENS
 . . . K @DIFDA@(DIFILE,DIEN,.001)
VALUES . .
 . . I DIFLAGS'["E" Q
 . . S DIFLD="",DIOUT3=0 F  D  Q:DIOUT3!$G(DIERR)
 . . . S DIFLD=$O(@DIFDA@(DIFILE,DIEN,DIFLD))
 . . . I DIFLD="" S DIOUT3=1 Q
 . . . I DIFLD=.01,$E(DIEN)="?",$E(DIEN,2)'="+" Q
 . . . S DIVAL=$G(@DIFDA@(DIFILE,DIEN,DIFLD))
 . . . D DTYP^DIOU(DIFILE,DIFLD,.DITYPE)
 . . . I DITYPE=5 S DINT=DIVAL
CONVERT . . .
 . . . I DITYPE'=5 D  Q:$G(DIERR)
 . . . . I DIEN["?"!(DIEN["+") D  Q:$G(DIERR)
 . . . . . I "@"[DIVAL D  Q
 . . . . . . I $P($G(^DD(DIFILE,DIFLD,0)),U,2)["R" D  Q
 . . . . . . . D ERR712(DIFILE,DIFLD)
 . . . . . . S DINT=DIVAL
 . . . . . N DA M DA=DIDA
 . . . . . N DIARG S DIARG="D0"
 . . . . . N DIMAX S DIMAX=$O(DA(""),-1)
 . . . . . N DIVAR F DIVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIVAR
 . . . . . N @DIARG F DIVAR=0:1:DIMAX-1 S @("D"_DIVAR)=DA(DIMAX-DIVAR)
 . . . . . S @("D"_DIMAX)=DA
 . . . . . N DIDA D CHK^DIE(DIFILE,DIFLD,"",DIVAL,.DINT)
 . . . . E  D  Q:$G(DIERR)
 . . . . . N DIVALFLG S DIVALFLG="R"_$E("Y",DIFLAGS["Y")
 . . . . . D VAL^DIE(DIFILE,DIEN,DIFLD,DIVALFLG,DIVAL,.DINT)
 . . . . Q:$D(DINUM)[0
 . . . . S @DINUMS@(@DIRULE@("NUM"))=DINUM K DINUM
 . . . S @DIRULE@("FDA",DIFILE,DIEN,DIFLD)=DINT
CLEANUP 
 I $G(DIERR)!'DIOK K @DIRULE Q
 K @DIRULE@("L"),@DIRULE@("NUM"),@DIRULE@("OP"),@DIRULE@("ROOT")
 K @DIRULE@("SEQ"),@DIRULE@("TEMP"),@DIRULE@("UP")
 S DIN=$NA(@DIRULE@("ORDER")),DIC=0
 F  S DIN=$Q(@DIN) Q:DIN=""!($P(DIN,",",3)'="""ORDER""")  D
 . S DIC=DIC+1,@DIRULE@("NEXT",DIC)=@DIN
 K @DIRULE@("ORDER")
 I DIFLAGS["E" S DIFDA=$NA(@DIRULE@("FDA"))
 Q
 
RID(DIFILE,DIEN,DIFDA,DIOK) 
 ; CHECK--return whether FDA entry sets all required identifiers
 ; func, all passed by value
 N DIP S DIP=$P(DIEN,",")
 I $E(DIP)="?","@"[$G(@DIFDA@(DIFILE,DIEN,.01)) Q "0^.01"
 N DIOK S DIOK=1
 N DIC,DIR F DIC=1:1 S DIR=$P(DIRID,U,DIC) Q:DIR=""  D  I 'DIOK Q
 . I DIP'["+",$D(@DIFDA@(DIFILE,DIEN,DIR))[0 Q
 . S DIOK="@"'[$G(@DIFDA@(DIFILE,DIEN,DIR)) I 'DIOK S DIOK=DIOK_U_DIR
 Q DIOK
 
ERR712(DIFILE,DIFIELD) 
 N DIFILNAM S DIFILNAM=$$GET1^DID(DIFILE,"","","NAME")
 N DIFLDNAM S DIFLDNAM=$$GET1^DID(DIFILE,DIFIELD,"","LABEL")
 D ERR^DICA3(712,DIFILE,"",DIFIELD,DIFLDNAM,DIFILNAM)
 Q

DICA2
DICA2 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor Part 2 ;11/15/94  16:20 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
IEN(DIFILE,DIEN,DIDA,DIRULE,DIOK) 
 ; ENTRY POINT--return whether the IEN String is valid
 ; proc, DIEN passed by value
 I $G(DIFILE("C"))'=DIFILE D PARENTS^DIDU1(.DIFILE,DIRULE)
 I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q
 I DIFILE("L")+1'=$L(DIEN,",") D ERR^DICA3(205,"",DIEN,"",DIFILE) Q
 I $E(DIEN)=","!(DIEN[",,") D ERR^DICA3(307,"",DIEN) Q
 K @DIRULE@("TEMP")
PIECES 
 K DIDA N DICRSR,DIOUT S DIOUT=0 F DICRSR=1:1 D  Q:DIOUT!$G(DIERR)
 . N DIPIECE S DIPIECE=$P(DIEN,",",DICRSR)
 . N DIRIGHT S DIRIGHT=$P(DIEN,",",DICRSR+1,99999)
 . I DIPIECE="" S DIOUT=1,DIOK=1 Q
 . D PIECE(.DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,.DIDA,DIRIGHT,.DIOK)
 . I $G(DIERR) S DIOK=0 Q
 . I 'DIOK D ERR^DICA3($S(DIOK=0:308,1:310),"",DIEN) Q
 . Q
 I $G(DIERR) Q
ALLGOOD 
 M @DIRULE@("SEQ")=@DIRULE@("TEMP")
 N DIN S DIN="S DIFILE="_DIFILE_",DIENTRY="""_DIEN_""""
 S @DIRULE@("ORDER",@DIRULE@("OP"),DIFILE("L"),DIFILE,@DIRULE@("NUM"))=DIN
 Q
 
PIECE(DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,DIDA,DIRIGHT,DIOK) 
 ; IEN--return whether a piece of the IEN String is valid
 ; proc, DIF, DIOK, & DIRULE passed by ref
 N DICHECK,DIF,DIPREFIX,DIR,DISEQ
 S DIF=DIFILE(DICRSR)
 I DIPIECE'["+",DIRIGHT["+" S DIOK=0 Q
FILING I +DIPIECE=DIPIECE,$E(DIPIECE)'="+" D  Q
 . S DIOK=DIPIECE>0 I 'DIOK Q
 . S DIOK=DIRIGHT'["+"&(DIRIGHT'["?") I 'DIOK Q
 . S DIR=$G(@DIRULE@("ROOT",DIF,","_DIRIGHT))
 . I DIR="" D
 . . S DIR=$$ROOT^DIQGU(DIF,","_DIRIGHT,1,1)
 . . S @DIRULE@("ROOT",DIF,","_DIRIGHT)=DIR
 . S DIOK=$P($G(@DIR@(DIPIECE,0)),U)'=""
 . I 'DIOK D ERR^DICA3(601,DIFILE,DIPIECE_","_DIRIGHT) Q
 . I DICRSR=1 S DIDA=DIPIECE
 . E  S DIDA(DICRSR-1)=DIPIECE
 . I DICRSR'=1 Q
 . S @DIRULE@("OP")=4
 . S @DIRULE@("NUM")=DIPIECE
PREFIX S DIPREFIX=$E(DIPIECE,1,2) I DIPREFIX'="?+" S DIPREFIX=$E(DIPREFIX)
 I DIPREFIX'="+",DIPREFIX'="?",DIPREFIX'="?+" S DIOK=0 Q
 
GOODPC I $P(DIPIECE,DIPREFIX,2,9999)?1N.N S DIOK=1 D  Q
 . S DISEQ=$P(DIPIECE,DIPREFIX,2,999)
 . I +DISEQ'=DISEQ S DIOK=0 Q
FIRSTPC . I DICRSR=1 D
 . . S @DIRULE@("OP")=$S(DIPREFIX="?":1,DIPREFIX="+":2,1:3)
 . . S @DIRULE@("NUM")=DISEQ
WHEREPC . S DICHECK=""
 . I $D(@DIRULE@("SEQ",DISEQ)) S DICHECK=$NA(@DIRULE@("SEQ"))
 . E  I $D(@DIRULE@("TEMP",DISEQ)) S DICHECK=$NA(@DIRULE@("TEMP"))
ILLEGAL . I DICHECK'="" D  I 'DIOK Q
 . . I $O(@DICHECK@(DISEQ,""))'=DIPREFIX S DIOK="C" Q
 . . I $O(@DICHECK@(DISEQ,DIPREFIX,""))'=DIF S DIOK="C" Q
 . . I $G(@DICHECK@(DISEQ,DIPREFIX,DIF))'=DIRIGHT S DIOK="C" Q
 . I DICHECK="",'$D(@DIFDA@(DIF,DIPIECE_","_DIRIGHT)) S DIOK="C" Q
LEARN . S @DIRULE@("TEMP",DISEQ,DIPREFIX,DIF)=DIRIGHT
 . I DICRSR=1 S DIDA=DIPREFIX
 . E  S DIDA(DICRSR-1)=DIPREFIX
 
BADPIEC S DIOK=0 Q

DICA3
DICA3 ;SEA/TOAD-VA FileMan: Updater, Adder ;7/24/95  13:18 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11834;1508202
 
CREATE(DIFILE,DIEN,DIROOT,DIVALUE) 
 N DIENP S DIENP=","_$P(DIEN,",",2,999)
 S DIEN=$P(DIEN,",")
 N DINEXT S DINEXT=$P($G(@(DIROOT_"0)")),U,3)
 I DINEXT="" D  I $G(DIERR) S DIEN="" Q
 . N DIHEADER S DIHEADER=$$HEADER^DIDU2(.DIFILE,DIENP)
 . I '$G(DIERR) S @(DIROOT_"0)")=DIHEADER
GETNUM 
 N DINUM S DINUM=DIEN'="" I 'DINUM S DIEN=DINEXT\1
 N DIFAIL,DIOUT S DIFAIL=0,DIOUT=0 F  D  I DIOUT!DIFAIL Q
 . I 'DINUM S DIEN=DIEN+1
 . L +@(DIROOT_"DIEN)"):1
 . I '$T S DIFAIL=DINUM Q:'DIFAIL  D ERR(110,DIFILE,DIEN_DIENP) Q
 . I $D(@(DIROOT_"DIEN)")) L -@(DIROOT_"DIEN)") D  Q
 . . S DIFAIL=DINUM I 'DIFAIL Q
 . . D ERR(302,DIFILE,DIEN_DIENP)
 . S DIOUT=1
 I DIFAIL S DIEN="" Q
SETREC 
 S @(DIROOT_"DIEN,0)")=DIVALUE
 L +@(DIROOT_"0)"):1
 S $P(^(0),U,3,4)=DIEN_U_($P(@(DIROOT_"0)"),U,4)+1)
 I  L -@(DIROOT_"0)")
 S DIEN=DIEN_DIENP
 D XA^DIEFU(DIFILE,DIEN,.01,DIVALUE,"")
 Q
 
PROOT(DIFILE,DIEN) 
 ; ENTRY POINT--return the global root of a subfile's parent
 ; extrinsic function, all passed by value
 N DIENP S DIENP=$P(DIEN,",",2,999)
 Q $NA(@$$ROOT^DILFD($$PARENT(DIFILE),DIENP,1)@(+DIENP))
 
PARENT(DIFILE) 
 ; ENTRY POINT--return the file number of a subfile's parent
 ; extrinsic function, all passed by value
 Q $G(^DD(DIFILE,0,"UP"))
 
SUBFILE(DIFILE) 
 ; ENTRY POINT--return whether the file is a subfile
 ; extrinsic function, passed by value
 Q $D(^DD(DIFILE,0,"UP"))#2
 
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) 
 ; error logging procedure
 N DIPE
 N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 Q

DICATT
DICATT ;SFISC/GFT,XAK-MODIFY FILE ATTR ;10/6/94  12:54
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DLAYGO=1 D D^DICRW Q:Y<0  I $P($G(^DD(+Y,0,"DI")),U)["Y",($P(@(^DIC(+Y,0,"GL")_"0)"),U,4)) W !!,$C(7),"DATA DICTIONARY MODIFICATIONS ON ARCHIVE FILES ARE NOT ALLOWED!" Q
 I '$D(DIC) D DIE^DIB Q:'$D(DG)  S DIC=DG
 S:$D(DIAX) DIAXDIC=+$P(@(DIC_"0)"),U,2)
EN ;
 K I S Q="""",I(0)=DIC,B=+$P(@(DIC_"0)"),U,2),S=";"
B ;
 K DA,J,DIU0,DDA S A=B,DICL=0,J(0)=B I $D(^DD(A,0,"DDA")),^("DDA")["Y" S DDA=""
M ;
 I $G(Z)["W",A-B G B
 W !!! K O,DQ,DIC,DIE,DG,M G Q^DIB:$D(DTOUT)
 S O=1,E=0,DIC(0)="ALEQIZ",DIC="^DD("_A_"," S:$D(DICS) DIC("S")=DICS
 S DIC("W")="S %=$P(^(0),U,2) I % W $P(""  (multiple)^  (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)"
 I $P(^DD(A,.01,0),U,2)["W" S DIC(0)="AEQZ",DIC("B")=.01
 E  I $D(DA),$D(^DD(A,DA,0)),'$P(^(0),U,2),$P(^(0),U,4)'?.P S E=DA
 D ^DIC S:$D(DDA)&$P(Y,U,3) DDA="N" I Y<0 G B:A-B,Q^DICATT2
 I '$P(Y,U,3) S DIU0=A,O(1)=$P(^DD(A,+Y,0),U,1,2),O(2)=$S($D(^(.1)):$P(^(.1),U),1:"") I $D(DDA) S DDA="E" D SV^DICATTA
 S:$D(DDA) DDA(1)=A
 S DIAC="AUDIT",DIFILE=A D ^DIAC S O=+% K DIAC,DIFILE
SKP S DA=+Y,DA(1)=A,DIE=DIC,M=Y(0),T=$P(M,U,2) S:T["C"!(T["W") O=0
 S DR=$P(".01:.1;",U,DUZ(0)="@"!'$F(T,"X"))_$P("1.1;",U,O)_$S(DUZ(0)="@"&(T'["C")&(T'["W"):"1.2;",1:"")_$S(T["C":"8;",1:"8:9;10:")_"11;20:29"
 S O=$S($P(Y,U,3):0,1:1_U_$P(M,U,2,99)),F=$P(M,U) K DIC,DQI
 S X=0 F  S X=$O(^DD(A,DA,1,X)) Q:X'>0  I +^(X,0)=B,$P(^(0),B,2)?1"^"1.A S DQI=$P(^(0),U,2)
 S X=-1 I 'T D DIE:O  Q:$D(DTOUT)  S:'$D(DA)&($D(DDA)) DDA="D" G TYPE^DICATT2:$D(DA),N:$P(O,U,4)?.P,^DICATT4
 S DR=".01;8;9;10:11;20:29" D DIE I '$D(DA) S:$D(DDA) DDA="D" S DQ(+T)=0 G NEW^DICATT4
 S X=$P($P(M,U,4),S,1),M=^DD(A,DA,0),E=$P(M,U,1),A=+T,DICL=DICL+1,J(DICL)=A,Y=$E(Q,+X'=X),I(DICL)=Y_X_Y I E'=F S ^(0)=E_" SUB-FIELD^"_$P(^DD(A,0),U,2,9) K ^(0,"NM") S ^("NM",E)=""
 G 5:$P(M,U,2)["W",N
 ;
 ;
E S DE=^DD(A,E,0) W $P(DE,U,1) Q
 ;
P S DI=DIU0 I '$D(DA),$D(O(1)) S DA=D0 D DIPZ^DIU0 Q
 I $D(^DD(DI,DA,0)),O(1)'=$P(^(0),U,1,2) D DIPZ^DIU0 Q
 I $D(^(.1)),O(2)'=$P(^(.1),U) D DIPZ^DIU0 Q
 K DIU0 Q
 ;
N I $D(DDA),DDA]"" S:'$D(DA) DA=D0 D AUDT^DICATTA
 D:$D(DIU0) P S DIZZ=$S(('O&$D(DIZ)):DIZ,1:$P(O,U,2,3)) G M
 ;
X W $C(7),"    '",F,"' DELETED!" I $D(DDA) S DDA=$S(DDA="":"D",1:"")
 S DIK="^DD(A,",DA(1)=A D ^DIK G N
 ;
CHECK G:$P(^DD(A,DA,0),U,2)']"" X:$D(DTOUT) G NO^DICATT2
 ;
DIE ;
 N I,J
 D ^DIE
 Q
 ;
0 S C=$P(O,U,5,99) G @N
1 ;
2 G ^DICATT0
3 ;
4 G ^DICATT6
5 S W="0;1",(Z,DIZ)="W^",C="Q",V=1,L=1 G ^DICATT2:O,SUB^DICATT1
6 G ^DICATT3
7 G ^DICATT5
8 G VP^DICATT4
9 S (Z,DIZ)="K^",V=0,C="K:$L(X)>245 X D:$D(X) ^DIM",L=245
 S:$P(^DD(A,DA,0),U,4)]"" W=$P(^(0),U,4) G ^DICATT2:O,SUB^DICATT1

DICATT0
DICATT0 ;SFISC/GFT,XAK-DATES, NUMERIC ;5/4/93  2:05 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G @N
 ;
DIE K Y S DP=0 F  S DL=1,DP=$O(DQ(DP)) Q:DP=""  S:$D(DE(DP)) DG(DP)=DE(DP)
 S DP=-1 D DQ^DIED K DQ,DICATTZ G CHECK^DICATT:$D(Y)!$D(DTOUT),@(N_0)
 ;
1 S %DT="E",DQ="^I X'?1""DT"".NP D ^%DT S X=Y K:Y<0 X",DQ(1)="EARLIEST DATE (OPTIONAL)^D^^1"_DQ,DQ(0,2)="S:'$L(X) Y=""CAN""",DQ(3)="LATEST DATE^RD^^3"_DQ_" I $D(X),X<DG(1) K X"
 S P="<X!(" I C[P S DE(1)=$P($P(C,P,2),">X",1),DE(3)=$P($P(C,"K:",2),P,1)
 S DQ(4)="CAN DATE BE IMPRECISE (Y/N)^S^Y:YES;N:NO;^4^Q",DE(4)=$E("YN",$P(C,Q,2)["X"+1),DQ(4,3)="E.G., WOULD 'FEB, 1980' BE ALLOWED?"
 S DQ(5)="CAN TIME OF DAY BE ENTERED (Y/N)^S^Y:YES;N:NO;^5^S:X=""N"" (DG(7),DG(6))=X K:X=""N"" DQ(6)"
 S DQ(6)="CAN SECONDS BE ENTERED (Y/N)^S^Y:YES;N:NO;^6^S DG(6)=X",DE(6)=$E("NY",$P(C,Q,2)["S"+1)
 S DE(5)=$E("NY",$P(C,Q,2)["T"+1),DQ(5,3)="CAN USER ENTER TIME ALONG WITH DATE, AS IN 'JULY 20@4:30'?"
 S DQ(7)="IS TIME REQUIRED (Y/N)^S^Y:YES;N:NO;^7^Q",DQ(7,3)="MUST USER ENTER TIME ALONG WITH DATE",DQ(0,6)="I X=""N"" S Y=U,DQ=DQ+1",DE(7)=$E("NY",$P(C,Q,2)["R"+1)
 S DICATTZ=1 G DIE
 ;
10 S C="S %DT=""E"_$E("S",DG(6)="Y")_$E("T",DG(5)="Y")_$E("X",DG(4)="N")_$E("R",DG(7)="Y")_""" D ^%DT S X=Y K:"
 F X=1,3 G ND:'$D(DG(X)) S Y(X)=$S(DG(X):DG(X)\10000+1700,1:DG(X)) I DG(X)#100 S Y(X)=DG(X)#100_"/"_Y(X) I $E(DG(X),4,5) S Y(X)=+$E(DG(X),4,5)_"/"_Y(X)
 I DG(1)]"" S M="TYPE A DATE BETWEEN "_Y(1)_" AND "_Y(3),C=C_DG(3)_P_DG(1)_">X) X" G ED
ND S C=C_"Y<1 X"
ED S Z="D^",L=DG(5)="Y"*5+7,DG(6)="" G H
 ;
2 K DG S DQ("A1")="!(X'["".""&($L(X)>15))!(X["".""&($L($P(+X,"".""))+$L($P(+X,""."",2))>15)) X"
 S DQ(1)="INCLUSIVE LOWER BOUND^R^^1^K:+X'=X"_DQ("A1"),DQ(2)="INCLUSIVE UPPER BOUND^R^^2^K:X<DG(1)!(+X'=X)"_DQ("A1"),DQ(3)="IS THIS A DOLLAR AMOUNT (Y/N)^S^Y:YES;N:NO;^3^Q" K DQ("A1")
 S P="1"".""",Z=$S(C["$":3,1:+$P(C,P,2)),DE(3)=$E("NY",C["$"+1),DE(5)=$S(Z:Z-1,1:0)
 S DQ(0,4)="S:X=""Y"" Y=U,DQ=9,DG(5)=2",DQ(5)="MAXIMUM NUMBER OF FRACTIONAL DIGITS^RN^^5^K:X'?1N X"
 I O S DE(1)=+$P(C,"X<",2),DE(2)=+$P(C,"X>",2)
 G DIE
20 I DG(1)>DG(2) W $C(7),"??" G 2
 S M="Type a "_$P("Number^Dollar Amount",U,DG(3)="Y"+1)_" between "_DG(1)_" and "_DG(2)_", "_DG(5)_" Decimal Digit"_$E("s",DG(5)'=1)
 S C="K:+X'=X",T=DG(5)+1,Z="!(X?.E"_P_T_"N.N)"
 I DG(3)="Y",DA-.001 S C="S:X[""$"" X=$P(X,""$"",2) K:X'?"_$P(".""-""",U,DG(1)<0)_".N."_P_".2N",Z=""
 S C=C_"!(X>"_DG(2)_")!(X<"_DG(1)_")"_Z_" X",L=$L(DG(2)\1)+T-(T=1),Z="NJ"_L_","_DG(5)_U
H S DIZ=Z G ^DICATT1

DICATT1
DICATT1 ;SFISC/GFT,XAK-NODE AND PIECE, SUBFILE ;2/16/93  17:14 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DA=.001 S W=" " G 2
 S (DG,W)=$P(O,U,4) G M:W="" S T=0,DP=DA,Y=$P(W,";",1),N=$P(W,";",2) D MX S L=L-T D MAX I T<252 S W=DG G ^DICATT2
 D TOO G NO^DICATT2
M K DE,DG W !,"WILL "_F_" FIELD BE MULTIPLE" S %=2 D YN^DICN I % S V=%=1 G BACK:%<0,SUB
 W !,"FOR A GIVEN ENTRY, WILL THERE BE MORE THAN 1 "_F,!," ON FILE AT ONCE?" G M
E ;
 S V=0,DE(3)=$S($D(^(3)):^(3),1:""),T=0,DP=E,N=$P($P(DE,U,4),";",2) D MX S L=T
SUB S:$P(DIZ,"^")["K" V=1 S T=0 F Y=0:1 Q:'$D(^DD(A,"GL",Y+1))
 D MAX:'V I T>245!$D(^DD(A,"GL",Y,0))!V S Y=$S(+Y=Y:Y+1,1:$C($A(Y)+1))
 G SB:DUZ(0)'="@"
 W !!,"SUBSCRIPT: ",Y,"// " R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=Y
 I X'?.ANP W !?5,$C(7),"Control Characters are not allowed." G SUB
 I +X'=X G BACK:X[U,DICATT1^DIQQQ:X["?" I X?1P.E!(X[",")!(X[":")!(X[S)!(X[Q)!(X["=") G SUB
 I Y'=X S Y=X D MAX I T>250 D TOO G SUB
SB S W=Y,X=0 G V:V,U:$D(^DD(A,"GL",W,0))
PIECE S Y=1,P=0
PC S X=$O(^DD(A,"GL",W,X)) I X'="" S P=$P(X,",",2),Y=$S(Y>P:Y,1:P+1) G PC
 S X=-1 I P S Y="E"_Y_","_(L+Y-1)
 E  F Y=1:1 Q:'$D(^(Y))
 S P=Y I DUZ(0)="@" W !,"^-PIECE POSITION: ",Y,"// " R P:DTIME S:'$T DTOUT=1 G CHECK^DICATT:$D(DTOUT) S:P="" P=Y
 G PQ:P["?" I P?1"E"1N.N1","1N.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'<L W $C(7),!,"CAN'T BE <",L G PIECE
 I P>0,P<100,P\1=P G USED
 S W="" I X'[U W $C(7),"??" G SUB
BACK G CHECK^DICATT:$D(DTOUT),TYPE^DICATT2
 ;
PQ W "  TYPE A NUMBER FROM 1 TO 99"
 I Y=1 W !?9,"OR AN $EXTRACT RANGE (E.G., ""E2,4"")"
 E  W !?15,"CURRENTLY ASSIGNED:",! S Y="" F P=0:0 S Y=$O(^DD(A,"GL",W,Y)) Q:Y=""  S P=$O(^(Y,0)) I $D(^DD(A,P,0)) W ?11,$S(Y:"PIECE ",1:"")_Y,?22,"FIELD #"_P_", '"_$P(^(0),U,1)_"'",!
 G PIECE
 ;
USED S W=W_S_P,X=P G DE:'$D(^(X))
U W !,$C(7),X_" ALREADY USED FOR "_$P(^DD(A,$O(^(X,0)),0),U,1) G SUB
 ;
MAX S N=0 F T=L:0 S N=$O(^DD(A,"GL",Y,N)) Q:N=""  S DP=$O(^(N,0)) D MX
 S N=-1 Q
MX I N?1"E".E S T=T+$P(N,",",2)-$E(N,2,9)+1
 Q:'N  S P=$P(^DD(A,DP,0),U,2),W=$S(P["J":$P(P,"J",2),P["P":9,P["N":14,P["D":7,1:0) G W:W
 I P["S" F P=1:1 S X=$L($P($P($P(^(0),U,3),";",P),":",1)) S:X>W W=X G W:'X
 S W=$P(^(0),"$L(X)>",2),W='W*30+W
W S T=T+W+1 Q
 ;
V I $D(^DD(A,"GL",W)) W $C(7),!?9,"CAN'T STORE A "_$S($P(DIZ,U)["K":"MUMPS",1:"MULTIPLE")_" FIELD IN AN ALREADY-USED SUBSCRIPT!" G SUB
 I $P(Z,U)'["K" S W=W_S_0 S:$P(DIZ,U)["K" W=$P(W,";")_";E1,245"
DE I $D(DE) S ^DD(A,DA,0)=F_U_$P(DE,U,2,3)_U_W_U_$P(DE,U,5,99),DIK="^DD(A,",DA(1)=A,^(3)=DE(3),^("DT")=DT D IX1^DIK G N^DICATT
2 S:$P(Z,U)["K" V=0,W=W_";E1,245",M="This is Standard MUMPS code." G ^DICATT2
 ;
TOO W $C(7),!," TOO MUCH TO STORE AT THAT SUBSCRIPT!"

DICATT2
DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;10/4/94  11:00
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S T=$E(Z,1) G CHECK^DICATT:$D(DTOUT)
 F P="I","O","L" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2)
1 K DS S:$P(Z,U)'["K" V=W[";0"
 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"
 S:T="*" T=$S($P(Z,U,1)["S":"S",1:"P") G 1^DICATT22:DA=.001
 G W:T="W" S:$D(DTIME)[0 DTIME=300
 I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y"
S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),S,3)_F_$P($T(DQ+Y),S,4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q
 S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1
 I T["P"!(T["N") S DE(5,0)="YES"
 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)
 K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U,1)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT
 S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U,1)'["R" S Z="R"_Z
 I $D(DG(6)),DG(6)="Y",$P(Z,U,1)'["M" S Z="M"_Z
G S DIZ=Z G ^DICATT22
Q ;
 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
 ;
W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN
 G CHECK^DICATT:%<0 I % S Z=$P($P(Z,"L",1)_$P(Z,"L",2),U,1)_$E("L",%=2)_U G G
 W !?3,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT"
 W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES."
 W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT"
 W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W
 ;
X ;
 W "   (FIELD DEFINITION IS NOT EDITABLE)" S T=$E(^(0),1),Z=$P(Y,U,2),Z=$P(Z,"M",1)_$P(Z,"M",2),Z=$P(Z,"R",1)_$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
 ;
NO ;
 W !,$C(7),"  <DATA DEFINITION UNCHANGED>" I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT
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,1),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
 F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N)
 W $P(^DOPT("DICATT",N,0),U,1) G X:$P(Y,U,2)["K"&(DUZ(0)'="@")
 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:"")
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
 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
 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"
 G TYPE
 ;
DQ ;;
 ;
 ;
 ;
 ;;IS ; ENTRY MANDATORY
 ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES
 ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER

DICATT22
DICATT22 ;SFISC/GFT-CREATE A SUBFILE ;10/6/94  13:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G M:V I P,$D(^DD(J(N-1),P,0)) S I=A_$E("I",$P(^(0),U,2)["I") D P
 I O,DA=.01,'N S I=$P(@(I(0)_"0)"),U,2) D P
1 ;
 S %=$L(F)+$L(W)+$L(C)+$L(Z) I %>242 W $C(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!" G TYPE^DICATT2
 I T["P",$D(O)=11,+$P($P(O(1),U,2),"P",2)'=+$P(Z,"P",2) S X=$P(O(1),U,2),DA(1)=A X:$D(^DD(0,.2,1,3,2)) ^(2)
 S ^DD(A,DA,0)=F_U_Z_U_W_U_C S:$P(Z,U)["K" ^(9)="@" D SDIK,I G N^DICATT
 ;
Q W $C(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE"
M S %=$P(A,".",1),DE=%_"."_+$P(A,".",2)_DA I +DE'=DE!$D(^DD(DE)) F DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001 Q:DE>A&'$D(^DD(DE))
 I DUZ(0)="@" W !,"SUB-DICTIONARY NUMBER: "_DE_"// " R DG:DTIME S:'$T DTOUT=1 G:DG=U!'$T ^DICATT2 S:DG]"" DE=DG G Q:+DE'=DE!(DE<A)
 G Q:%+1'>DE!$D(^DD(DE)) S I=DE,^(I,0)=F_" SUB-FIELD^^.01^1",^(0,"UP")=A,^("NM",F)="",^DD(A,DA,0)=F_"^^^"_W D P S:T["V" %X="^DD("_A_","_DA_",""V"","
 S W=$P(W,S,1) D SDIK S:+W'=W W=Q_W_Q
 S (N,DICL)=N+1,I(N)=W,J(N)=DE,DA=.01,^DD(DE,DA,0)=F_U_Z_"^0;1^"_C I T["V" S %Y="^DD("_DE_",.01,""V""," D %XY^%RCR K @($E(%X,1,$L(%X)-1)_")"),%X,%Y I $D(^DD(DE,DA,0))
 I T'["W" S ^(1,0)="^.1",^(1,0)=DE_"^B",DIK=W_",""B"",$E(X,1,30),DA)" F %=DICL-1:-1 S DIK=I(%)_$E(",",1,%)_"DA("_(DICL-%)_"),"_DIK I '% S ^(1)="S "_DIK_"=""""",^(2)="K "_DIK S:T["V" ^(3)="Required Index for Variable Pointer" Q
 D SDIK,I S DICL=DICL-1 G N^DICATT
 ;
I I $P(O,U,2,99)'=$P(^DD(J(N),DA,0),U,2,99) S:$D(M)#2 ^(3)=M S M(1)=0,^("DT")=DT,^DD(J(N),0,"DT")=DT F DR=J(N):0 Q:'$D(^DD(DR,0,"UP"))  S DR=^("UP"),^DD(DR,0,"DT")=DT
 K DR,DG,DB,DQ,DQI,^DD(U,$J),^UTILITY("DIVR",$J)
 S DIE=DIK,DR=$S(DUZ(0)="@":"3;4",1:3)_$P(";21",U,'O) D DIE I T="W" K DE
 I $D(M)>9,O S V=DICL,DR=$P(Z,U,1),Z=$P(Z,U,2) I @("$O("_I(0)_"0))>0") D V S:'$D(DA) DA=DIFLD
 K DR,M Q
 ;
DIE ;
 N I,J
 D ^DIE
 Q
 ;
V S DI=J(N) D DIPZ^DIU0 Q:T="W"!$D(DTOUT)!'$D(DIZ)
 W !!,"SINCE YOU HAVE CHANGED THE FIELD DEFINITION,",!,"EXISTING '",F,"' DATA WILL NOW BE CHECKED FOR INCONSISTENCIES",!,$C(7),"OK"
 S %=1 D YN^DICN Q:%-1  S DDC=C,$P(Y(0),U,4)=W,DIFLD=D0,Z=$P(DIZ,U,2),DR=$P(DIZ,U) G ^DIVR
 ;
P F Y="S","D","P","A","V" S:I[Y I=$P(I,Y,1)_$P(I,Y,2)_$P(I,Y,3) S:T[Y I=I_Y
 S ^(0)=$P(^(0),U,1)_U_I_U_$P(^(0),U,3,99) Q
 ;
SDIK S DA(1)=J(DICL),DIK="^DD("_DA(1)_"," I O K ^DD(DA(1),"RQ",DA)
 W !,"...." G IX1^DIK

DICATT3
DICATT3 ;SFISC/XAK-COMPUTED FIELDS ;1/11/91  2:21 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
6 W !!,"'COMPUTED-FIELD' EXPRESSION: " I O,$D(^DD(A,DA,9.1)) S (X,Y)=^(9.1),%=$L(X)>19 W X W:'% "// " I % D RW^DIR2 W ! G 61
 R X:DTIME,! S:'$T X=U,DTOUT=1
61 K DICOMPX S DICOMPX="" I U[X G:X=U N^DICATT:O,CHECK^DICATT G 6:'O D DEC:$P($P(O,U,2),"J",1)="C" G N^DICATT
 G DICATT3^DIQQ:X?."?" S Z=X,DQI="Y("_A_","_DA_",",DICMX="X DICMX",DICOMP="?I"
 D ^DICOMP I '$D(X) W $C(7),"  ...",I,"??" G 6
 I DUZ(0)="@" W !,"TRANSLATES TO THE FOLLOWING CODE:",!,X,!
 I Y["m" W !,"FIELD IS 'MULTIPLE-VALUED'!",!
 I O,$D(^DD(A,DA,9.01))!(DICOMPX]"") D ACOMP
 S (Y,DATE)=$E("D",Y["D")_$E("B",Y["B")_"C"_$S(Y'["m":"",1:"m"_$E("w",Y["w")),^DD(A,DA,0)=F_U_Y_"^^ ; ^"_X,^(9)=U,^(9.1)=Z,^(9.01)=DICOMPX
 F Y=9.2:.1 Q:'$D(X(Y))  S ^(Y)=X(Y)
 K X,DICOMPX D SDIK^DICATT22:'O,DEC:DATE="C" I O S DI=A D PZ^DIU0
 K DATE G N^DICATT
 ;
ACOMP ;SET/KILL ACOMP NODES
 N X,I I $D(^DD(A,DA,9.01)),^(9.01)]"" S X=^(9.01) X ^DD(0,9.01,1,1,2)
 I DICOMPX]"" S X=DICOMPX X ^DD(0,9.01,1,1,1)
 Q
DEC S C=$P(^DD(A,DA,0),U,2),Y="",Z=$P(C,"J",2) F J=0:0 S N=$E(Z,1) Q:N?.A  S Z=$E(Z,2,99),Y=Y_N
 W !,"NUMBER OF FRACTIONAL DIGITS TO OUTPUT (ONLY ANSWER IF NUMBER-VALUED): " S N=$P(Y,",",2),E=$S(Y:+Y,1:8) I N]"" W N,"// "
 R DG:DTIME S:'$T DTOUT=1 Q:DG[U!'$T  S N=$S(DG="":N,DG="@":"",1:DG) G S:N="",DICATT31^DIQQ:N'?1N
 I C?1"D".E S C=$E(C,2,99),^(0)=$P(^(0),U,1)_U_C_U_$P(^(0),U,3,99)
 S DG=" S X=$J(X,0,",M=$P(^(0),DG,1),%=M_DG_N_")"'=^(0)+1 W !,"SHOULD VALUE ALWAYS BE INTERNALLY ROUNDED TO ",N," DECIMAL PLACE",$E("S",N'=1) D YN^DICN G DEC:'% Q:%'>0  S ^(0)=M_$P(DG_N_")",U,%)
S S DQI="Y(",O=$D(^(9.02)),X=^(9.1) K DICOMPX,^(9.02) G J:'$D(^(9.01))
 F Y=1:1 S M=$P(^(9.01),";",Y) Q:M=""  S DICOMPX(1,+M,+$P(M,U,2))="S("""_M_""")",DICOMPX=""
 G J:Y<2 I X'["/",X'["\" G J:X'["*",J:Y<3
 D ^DICOMP G J:$D(X)-1
 S %=2-O W !,"WHEN TOTALLING THIS FIELD, SHOULD THE SUM BE COMPUTED FROM",!?7,"THE SUMS OF THE COMPONENT FIELDS" D YN^DICN
 I %=1 S ^DD(A,DA,9.02)=X_" S Y=X"
J K DICOMPX Q:$D(DTOUT)  W !,"LENGTH OF FIELD: ",E,"// " R DG:DTIME S:'$T DTOUT=1 Q:DG[U!'$T  I DG,DG\1=DG S E=DG G 0
 I DG]"" W !,"MAXIMUM NUMBER OF CHARACTERS" G J
0 S ^(0)=$P(^DD(A,DA,0),U,1)_U_$P(C,"J",1)_"J"_E_$E(",",N]"")_N_Z_U_$P(^(0),U,3,99)

DICATT4
DICATT4 ;SFISC/XAK-DELETE A FIELD ;5/7/93  1:42 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIEZ S DI=A,DA=D0 D DIPZ^DIU0
 K ^DD(A,0,"ID",D0),^DD(A,0,"SP",D0)
EN I $O(@(I(0)_"0)"))'>0 G N
 S %=1,Y=$P(O,U,4),X=$P(Y,S,1),Y=$P(Y,S,2),O=$S(+X=X:X,1:Q_X_Q)_")",E="^("_O
 I $O(^DD(A,"GL",X,""))="" S T="K ^(M,"_O G F
 I Y S T="U_$P("_E_",U,"_(Y+1)_",999) K:"_E_"?.""^"" "_E S:Y>1 T="$P("_E_",U,1,"_(Y-1)_")_U_"_T
 E  S X=+$E(Y,2,4),Y=+$P(Y,",",2) G N:'X!'Y S T="$E("_E_",1,"_(X-1)_")_$J("""","_(Y-X+1)_")_$E("_E_","_(Y+1)_",999)"
 S T="I $D(^(M,"_O_")#2 S "_E_"="_T
F I '$D(DIU(0)) W $C(7),!,"OK TO DELETE '",$P(M,U),"' FIELDS IN THE EXISTING ENTRIES" D YN^DICN G N:%-1
 S M="",X=DICL,Y=I(0) I $D(DQI) K @(I(0)_Q_DQI_""")")
L S O="M" S:X O=O_"("_X_")" S Y=Y_O,M=M_"F "_O_"=0:0 S "_O_"=$O("_Y_")) Q:"_O_"'>0  "
 S X=X-1 I X+1 S Y=Y_","_I(DICL-X)_"," G L
 X M_"X T"_$P(" W "".""",U,$S('$D(DIU(0)):1,DIU(0)["E":1,1:0))
N Q:$D(DIU)  G N^DICATT
NEW D KDD G DICATT4
 ;
VP ; VARIABLE POINTER
 S DA(2)=DA(1),DA(1)=DA,DICATT=DA I $D(DICS) S DICSS=DICS K DICS
V S DA(2)=A,DA(1)=DICATT,DIC="^DD("_A_","_DICATT_",""V"",",DIC("P")=".12P",DIC(0)="QEAMLI",DIC("W")="W:$S($D(^DIC(+^(0),0)):$P(^(0),U)'=$P(^DD(DA(2),DA(1),""V"",+Y,0),U,2),1:0) ?30,$P(^(0),U,2)" D ^DIC S DIE=DIC K DIC
 I Y>0 S DA=+Y,Z="P",DR=".01:.04;"_$S($P($G(^DD(+$P(Y,U,2),0,"DI")),U,2)["Y":".06///n",1:".06T")_";S:DUZ(0)'=""@"" Y=0;.05;I ""n""[X K ^DD(DA(2),DA(1),""V"",DA,1),^(2) S Y=0;1;2;" S:$P(Y,U,3) DIE("NO^")=""
 I Y>0 D ^DIE K DIE W ! S:$D(DTOUT) DA=DICATT G CHECK^DICATT:$D(DTOUT),V
 S Z="V^",DIZ=Z,C="Q",L=18,DA=DICATT,DA(1)=A S:$D(DICSS) DICS=DICSS K DICSS,DR,DIE,DA(2),DICATT G CHECK^DICATT:$D(DTOUT)!(X=U),^DICATT1
 Q
HELP ;
 W !?5,"Enter a MUMPS statement which begins with 'S DIC(""S"")=' and contains",!?5,"code which sets $T.  Those entries for which $T=1 will be selectable."
 I Z?1"P".E W !?5,"The naked reference will be at the zeroeth node of the pointed to",!?5,"file, e.g., ^DIZ(9999,Entry Number,0).  The number of the entry that",!?5,"is being processed in the pointed to file will be in the variable Y." Q
 W !?5,"The variable Y will be equal to the internally-stored code of the item",!?5,"in the set which is being processed."
 Q
KDD ;
 S DQ=$O(DQ(0)),X=0 S:DQ="" DQ=-1 Q:DQ<1  S Y=0 F  S X=$O(^DD(DQ,"SB",X)) S:X="" X=-1 S DQ(X)=0 D KIX Q:X<0
 S Y=0 F %=0:0 S Y=$O(^DD(DQ,Y)) Q:'Y  I $D(^(Y,9.01)) S X=^(9.01) D KACOMP
 K DQ(DQ),^DD(DQ),^DD("ACOMP",DQ),^DD(A,"TRB",DQ)
 S Y=0 F  S Y=$O(^DIE("AF",DQ,Y)) Q:Y=""  S %=0 F  S %=$O(^DIE("AF",DQ,Y,0)) Q:%=""  K ^(%),^DIE(%,"ROU")
 S Y=0 F  S Y=$O(^DIPT("AF",DQ,Y)) G KDD:Y="" S %=0 F  S %=$O(^DIPT("AF",DQ,Y,0)) Q:%=""  K ^(%),^DIPT(%,"ROU")
 ;
KIX S Y=$O(^DD(A,0,"IX",Y)) S:Y="" Y=-1 Q:Y<0  K:$D(^(Y,DQ)) ^(DQ) G KIX
 Q
KACOMP N DA,I,% S DA(1)=DQ,DA=Y X ^DD(0,9.01,1,1,2) Q

DICATT5
DICATT5 ;SFISC/XAK-POINTERS ;5/7/93  1:44 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
7 K DIC S Y="",%=$P(O,U,3),DIC(0)="EFQIZ"
 S:$P(O,U,2)["P"&$L(%) Y=$S($D(@("^"_%_"0)")):$P(^(0),U),1:"")
 W !,"POINT TO WHICH FILE: " W:Y]"" Y_"// " R X:DTIME S:'$T DTOUT=1 G CHECK^DICATT:X=U!'$T I Y]"",X="" S X=Y,DIC(0)=DIC(0)_"O"
 S DIC=1,DIC("S")="I Y'=1.1 S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
 D ^DIC K DIC,DIFILE,DIAC G:Y<0 7:X["?",T S X=^(0,"GL"),DE=Y G 77
T K DIC G CHECK^DICATT:$D(DTOUT),NO^DICATT2
77 S DIFILE=+Y,DIAC="LAYGO" D ^DIAC S %=0 S:'DIAC!($P($G(^DD(DIFILE,0,"DI")),U,2)["Y") %=2 K DIFILE,DIAC
P I % W !,$C(7) D A W !,"WILL NOT " D B
 E  S %=1+$S($P(O,U,2)["'":1,$P(O,U,2)']"":1,1:0) W !,"SHOULD " D A W ! D B,YN^DICN G T:%<1
 S Z="P"_+DE_$E("'",%=2)_X,C="Q",L=9,E=X G H:DUZ(0)'="@" D S G T:X=U,H
S ;
 S D=$S($D(^DD(A,DA,12.1)):^(12.1),1:""),%=2-(D]""),P=$S($D(^(12)):^(12),1:""),I=$S($D(^(12.2)):^(12.2),1:"")
 W !,"SHOULD '"_$P(DE,U,2)_"' ENTRIES BE SCREENED" D YN^DICN S:%<0 X=U Q:X=U  I '% W !?5,"Answer YES if there is a condition which should prohibit",!?5,"selection of some entries." G S
 I %=2 K ^(12.1),^(12),^(12.2) Q
 G M ;W !,"ENTER A TRUTH-VALUED EXPRESSION WHICH MUST BE TRUE OF ANY ENTRY POINTED TO:",!?4 I I]"" W I_"// " W:$X>35 !?4
 R X:DTIME S:'$T DTOUT=1 G T:X=U!'$T S:X="" X=I I X="" G M:DUZ(0)="@",S
 K DG,K S ^(12.2)=X,K=100,DQI="Y(",DG(K)=K,K(1,1)=K,(DLV,DLV0)=K,J(K)=+DE,I(K)=E,K=0 D EN^DICOMP
 G S:'$D(X) I $D(X)>1!(X[" ^DIC") W $C(7),!,"TOO COMPLICATED!" G S
 S I=0 I 'DBOOL W $C(7),!?8,"WARNING-- THIS DOESN'T LOOK LIKE A TRUTH-VALUED EXPRESSION"
D0 S I=$F(X,E_"D0",I) I I S X=$E(X,1,I-3)_"Y"_$E(X,I,999) G D0
Q S I=$F(X,"""",I) I I S X=$E(X,1,I-1)_""""_$E(X,I,999),I=I+1 G Q
 S (D,X)="S DIC(""S"")="""_X_" I X""" G E:DUZ(0)'="@"
M W !,"MUMPS CODE THAT WILL SET 'DIC(""S"")': " W:D]"" D S Y=D D:D]"" RW^DIR2 G S:X="@" I D']"" R X:DTIME S:'$T DTOUT=1 Q:X=U!'$T
 I X="" S X=D G S:X=""
 I X?."?" D HELP^DICATT4 G M
 D ^DIM:'$T I '$D(X) S X="" G S
E W !,"EXPLANATION OF SCREEN: " W:P]"" P_"// " R %:DTIME S:'$T %=U,DTOUT=1 S:%="" %=P G S:%=U I %?.P W !?5,$C(7),"An explanation must be entered." G E
 I $D(^DD(A,DA,12.1)) S:X'=^(12.1) M(1)=0
 S ^DD(A,DA,12)=%,^(12.1)=X,Z="*"_Z S:Z?1"*P".E C=X_" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X" Q
H S DIZ=Z G ^DICATT1
 ;
A W "'ADDING A NEW "_$P(DE,U,2)_" FILE ENTRY' (""LAYGO"")" Q
B W "BE ALLOWED WHEN ANSWERING THE "_F_"' QUESTION" Q
 Q

DICATT6
DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;10/12/90  9:35 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G @N
 ;
3 S Z="",L=1,P=0,Y="INTERNALLY-STORED CODE: "
P S P=P+1,C=$P($P(O,U,3),S,P) W !,Y W:C]"" $P(C,":",1)_"// " R T:DTIME G T:'$T
 I T_C]"" G P:T="@" S:T="" T=$P(C,":",1) S X=T,L=$S($L(X)>L:$L(X),1:L) D C I $D(X) W "  WILL STAND FOR: " W:C]"" $P(C,":",2),"// " R X:DTIME G:'$T T S:X="" X=$P(C,":",2) D C I $D(X) G TOO:$L(Z)+$L(T)+$L(X)+$L(F)>235 S Z=Z_T_":"_X_S G P:X]"",T
 G T:Z=""!'$D(X) S (DIZ,Z)="S^"_Z I DUZ(0)="@" S DE="^"_F D S^DICATT5 K DE G CHECK^DICATT:$D(DTOUT)!(X=U)
 S C="Q" G H
 ;
C I X["?",P=1 K X W !,"For Example: Internal Code 'M' could stand for 'MALE'",! Q
 I X[":"!(X[U)!(X[S)!(X[Q)!(X["=") K X W $C(7),!,"SORRY, ';' ':' '^' '""' AND '=' AREN'T ALLOWED IN SETS!",! Q
 I X'?.ANP W !,$C(7),"Cannot use CONTROL CHARACTERS!" K X
 Q
 ;
TOO W $C(7),!,"TOO MUCH!! -- SHOULD BE 'POINTER', NOT 'SET'"
T W ! G NO^DICATT2:'$D(X) S DTOUT=1 G CHECK^DICATT
 ;
4 K DG,DE,M S DL=1,L=1,DP=-1,DQ(1)="MINIMUM LENGTH^NR^^1^K:X\1'=X!(X<1) X",DQ(2)="MAXIMUM LENGTH^RN^^2^K:X\1'=X!(X>250)!(DG(1)>X) X"
 S T="",P=" X",DQ(3)="(OPTIONAL) PATTERN MATCH (IN 'X')^^^3^S X=""I ""_X D ^DIM S:$D(X) X=$E(X,3,999) I $D(X) K:X?.NAC X",DQ(3,3)="EXAMPLE: ""X?1A.A"" OR ""X'?.P"""
 G DIED:'O,DG:C'?.E1"K:$L".E1" X"
 S T=$P(C,"K:$L",1),DE(2)=+$P(C,"$L(X)>",2),DE(1)=+$P(C,"$L(X)<",2)
 S Y=0,I=0,Z=$P(C,")!'(",2,99) I Z="" K:'DE(2) DE(2) G DG
L S I=I+1,X=$E(Z,I) G L:X'?.P,DG:X="" I X=Q S Y='Y G L
 G L:Y I X="(" S L=L+1
 G L:X'=")" S L=L-1 G L:L
 S DE(3)=$E(Z,1,I-1),P=$E(Z,I+1,999)
DG S:$D(^DD(A,DA,3)) M=^(3) F L=1,2,3 S:$D(DE(L)) DG(L)=DE(L)
DIED K Y S DM=0 D DQ^DIED K DQ,DM G CHECK^DICATT:$D(DTOUT)!($D(Y))
 S Y=DG(1),L=DG(2),X=$S(L=Y:L,1:Y_"-"_L) I L<Y W $C(7),"??" G 4
 S Z="Answer must be "_X_" character"_$E("s",X'=1)_" in length." I $S($D(M):M'[Z,1:1) S M=Z
 S X=$S('$D(DG(3)):"",DG(3)="":"",1:"!'("_DG(3)_")")
 S C=T_"K:$L(X)>"_L_"!($L(X)<"_Y_")"_X_P
Z S (DIZ,Z)="F^"
H G ^DICATT1

DICATTA
DICATTA ;SFISC/YJK-DD AUDIT ;1/4/94  08:21
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
I S B1="0,.1,3,4,8,8.5,9,9.1,10,AUDIT,AX" Q
SV ;
 D I F %=1:1 S A0=$P(B1,",",%) Q:A0=""  I $D(^DD(A,+Y,A0)) S ^UTILITY("DDA",$J,A,+Y,A0)=^(A0)
 K %,A0,B1 Q
 ;
AUDT ;
 S B0=DDA(1) I DDA="E" D B G QQ
 S A0="LABEL^.01" D ADD I DDA["D" S ^DDA(B0,%D,1)=$P(^UTILITY("DDA",$J,B0,DA,0),U,1)
 E  S ^DDA(B0,%D,2)=$P(^DD(B0,DA,0),U,1)
 G QQ
 ;
B S A0="",A1=^UTILITY("DDA",$J,B0,DA,0),A2=^DD(B0,DA,0)
 S A3=1,A5="LABEL^TYPE^TYPE",B3=".01^.25^.25"
 F %=1:1:3 I $P(A1,U,%)'=$P(A2,U,%) S $P(A0,",",A3)=$P(A5,U,%),$P(A4,",",A3)=$P(B3,U,%),$P(B1,"^",A3)=$P(A1,U,%),$P(B2,"^",A3)=$P(A2,U,%),A3=A3+1
 I $P(A1,U,5,99)'=$P(A2,U,5,99) S $P(A0,",",A3)="INPUT TRANSFORM",$P(B1,"^",A3)=$P(A1,U,5,99),$P(B2,"^",A3)=$P(A2,U,5,99),$P(A4,",",A3)=.5
 I A0]"" S A0=A0_"^"_A4,A1=B1,A2=B2 D ADD,E
 K B3,A1,A2,A3,A4,A5 D I
B1 F B2=2:1 S %=$P(B1,",",B2) Q:%=""  S:$D(^UTILITY("DDA",$J,B0,DA,%)) A1=^(%) S:$D(^DD(B0,DA,%)) A2=^(%) I $D(A1)!$D(A2) S %=$S(%="AUDIT":1.1,%="AX":1.2,1:%),A0=$S($D(^DD(0,%,0)):$P(^(0),U,1),1:"")_"^"_% D P
 Q
 ;
P I $D(A1),'$D(A2) S DDA="D" D ADD S ^(1)=A1 K A1 Q
 I '$D(A1),$D(A2) S DDA="N" D ADD S ^(2)=A2 K A2 Q
 I A1'=A2 S DDA="E" D ADD,E
 K A1,A2 Q
 ;
ADD I '$D(^DDA(B0,0)) S %=$P(^DIC(J(0),0),U,1),^DDA(B0,0)=$S(B0=J(0):%,1:%_" ("_$P(^DD(B0,0),U,1)_")")_" DD AUDIT^.6I"
 F B3=$P(^(0),U,3):1 I '$D(^(B3)) L +^DDA(B0,B3):0 Q:$T
 S $P(^(0),U,3,4)=B3_U_($P(^(0),U,4)+1),^(B3,0)=DA L -^DDA(B0,B3)
 S %T=$P($H,",",2),%T=%T#60/100+(%T#3600\60)/100+(%T\3600)/100,%T=DT_%T
 S ^DDA(B0,"D",%T,B3)="",^DDA(B0,"E",DUZ,B3)="",^DDA(B0,"B",DA,B3)="",^DDA(B0,B3,0)=DA_U_DDA_U_%T_U_DUZ_U_A0_U_B0,%D=B3
 K B3,%T,% Q
 ;
E S:A1]"" ^(1)=A1 S:A2]"" ^(2)=A2 Q
 ;
IT ;
 S B0=DI,DDA="E" D ADD,E G QQ
 ;
IT1 ;
 S B1=",3,4,12.1",B0=DI D B1 G QQ
 ;
XS ;
 I $P(^DD(J(N),DA,1,DQ,0),U,3)["TRIG"!($P(^(0),U,3)["BULL") S DDA="TE" Q:'$D(^(3))  S ^UTILITY("DDA",$J,J(N),DA,3)=^(3) Q
 S %=0 F B1=1:1 S %=$O(^DD(J(N),DA,1,DQ,%)) Q:+%'>0  S ^UTILITY("DDA",$J,J(N),DA,B1)=^(%)
 K B1,% Q
 ;
XA ;
 S B0=J(N),DA=DL,A0="CROSS REFERENCE^1"
 I DDA["T" S DDA="E" D TR G QQ
 S %=0 D CK G:'% QQ D ADD S B1=$S(DDA["D":1.1,1:2.1),A0="^DD(B0,DA,1,DQ," D XL
QQ S DDA="" K B0,%D,B1,B2,%,A0,A1,A2,^UTILITY("DDA",$J) Q
 ;
CK K A1,A2 F B1=1:1:3 S:$D(^DD(B0,DA,1,DQ,B1)) A1=^(B1) S:$D(^UTILITY("DDA",$J,B0,DA,B1)) A2=^(B1) I $D(A1)!$D(A2) D C Q:%
 Q
 ;
C I ($D(A1)&'$D(A2))!('$D(A1)&$D(A2)) S %=1 Q
 S:A1'=A2 %=1 Q
 ;
XL S %=0 F B2=1:1 S %=$O(@(A0_%_")")) Q:+%'>0  S ^DDA(B0,%D,B1,B2,0)=^(%)
 S B2=B2-1,%=$S(B1=1.1:.601,1:.602),^DDA(B0,%D,B1,0)="^"_%_"^"_B2_"^"_B2_"^"_DT
 I DDA["E",B1=2.1 S B1=1.1,A0="^UTILITY(""DDA"",$J,B0,DA," G XL
 K %,B2 Q
 ;
TR ;
 K A1,A2 S:$D(^DD(B0,DA,1,DQ,3)) A2=^(3) S:$D(^UTILITY("DDA",$J,B0,DA,3)) A1=^(3) Q:'$D(A1)&'$D(A2)
 I $D(A1),$D(A2) Q:A1=A2  D ADD S ^DDA(B0,%D,1)=A1,^(2)=A2 Q
 D ADD S:$D(A1) ^DDA(B0,%D,1)=A1 S:$D(A2) ^DDA(B0,%D,2)=A2 Q
 ;;

DICD
DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;3/30/95  15:29
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DICD S (DA,DL)=+Y D CHIX I 'DQ D ^DICE G Q
 D RD G:$D(DIRUT) Q I Y["C" D ^DICE G Q
 I Y["E" D EDT^DICE G Q
 D DEL G Q
 ;
DEL I DH(DQ,4) D R Q:'$D(DICD)  S DQ=DICD
 I $D(DH(DQ,3)) W !?5,*7,"This cross-reference cannot be deleted.",! Q
ASK S %=2 W !,"Are you sure that you want to delete the CROSS-REFERENCE " D YN^DICN Q:(%<0)!(%=2)
 I %=0 W !?7,"Answer YES if you want to delete the Cross-Reference." G ASK
 W !,"  ...OK",! K:I["SOUNDEX" ^DD(DI,0,"LOOK"),^("QUES")
 S ^DD(J(N),DL,1,0)="^.1",X=^(DQ,2),Y=$P(I,U,2) I Y?1A.E,+I=J(0),I'["MNEM",I'["MUM" K @(I(0)_"Y)") G DDD
 G DDD:X="Q"!$F(I,"BUL") I I'["MUM",I'["TRIG" D DD G DDD
 S %=1 W "DO YOU WANT THE INDIVIDUAL CROSS-REFERENCE VALUES DELETED" D YN^DICN Q:%<1
 D DD:%=1
DDD I $D(DDA) S DDA="D" D XA^DICATTA
 S DIK="^DD(J(N),DL,1,",DA(1)=DL,DA(2)=J(N),DA=DQ D ^DIK K DIK,DA
 S DA=DL D DIEZ^DIU0
D I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ
 Q
 ;
CHIX ;
 K DH S DQ=0,X="CURRENT CROSS-REFERENCE"
 F Y=0:1 S DQ=$O(^DD(DI,DA,1,DQ)) Q:DQ'>0  S DH(DQ)=^(DQ,0),DH(DQ,4)=Y S:$D(^(3)) DH(DQ,3)=^(3)
 W !! I 'Y S DQ=0 W "NO ",X Q
 I Y=1 W X_" IS " S DQ=$O(DH(0)) D L Q:'$D(DICD)  S %=2 W !,"WANT TO "_DICD_" IT" D YN^DICN S:%=-1 DICDF=1 S:%=1 DICD=DQ Q
 D M Q:'$D(DICD)  S %=2 W !,"WANT TO "_DICD_" ONE OF THEM" D YN^DICN Q:%-1
R R !,"WHICH NUMBER: ",X:DTIME Q:U[X  I X\1'=X!'$D(DH(X)) D M G R
 S DICD=X,I=DH(X) Q
M W !,"CURRENT CROSS-REFERENCES:" F J=0:0 S J=$O(DH(J)) Q:J'>0  W !?8,J,?14 S DQ=J D L
 Q
 ;
L S I=DH(DQ),X=$P(I,U,3) S:X="" X="REGULAR" W X
 G E:X["BULL" I X["TRIGGER" S %=+$P(I,U,4),(%F,Y)=+$P(I,U,5) W " OF " D WR^DIDH:$D(^DD(%,Y,0)),N Q
 W " '",$P(I,U,2),"' INDEX OF " I +I=J(0) W "FILE"
 W:'$T $P(^DD(+I,0),U)
N W:$D(DH(DQ,3)) !?14,"("_DH(DQ,3)_")" Q
 ;
E F %="CREA","DELE" S %=%_"TE VALUE" I $D(^DD(DI,DA,1,DQ,%)),^(%)'="NO EFFECT" W "  ("_^(%)_")"
 D N Q
 ;
DD ;
 N DIKJ,DA,DV,DH,Y,DCNT,DIK S DIKJ=$J
 K ^UTILITY("DIK",$J) S J=J(N),^($J)=$H,^($J,J,DL,1)=X,Y=$P(^DD(DI,DL,0),U,4),^UTILITY("DIK",$J,J,DL)=$P(Y,";",1),Y=$P(Y,";",2),^(DL,0)="S X=$"_$S(Y:"P(^(X),U,"_Y_")",1:"E(^(X),"_+$E(Y,2,9)_","_$P(Y,",",2)_")")
 I $D(^DD(J,DL,1,DQ,"DIK")) S ^UTILITY("DIK",$J,J,DL,1)="D RCR",^(1,0)=X
 K Y,DA,DV,DH S DH(1)=J(0) F Y=1:1:N S DV(J(Y-1),1)=I(Y),DV(J(Y-1),1,0)=J(Y)
 D WAIT S DIK=DIU,DA=0,DCNT=0 G CNT^DIK1
 ;
KOLD K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO EXECUTE THE OLD KILL LOGIC NOW",DIR("?",1)="Enter 'YES' to execute the original kill logic now.",DIR("?")="Otherwise, enter 'NO'."
 D ^DIR K DIR I 'Y!$D(DIRUT) K DTOUT,DUOUT,DIRUT,DIROUT Q
 N DA W !!,"Executing old kill logic...",! S X=A1(2) D DD Q
WAIT ;
 W !,"..."
 W $P("HMMM^EXCUSE ME^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$R(6)+1)_"..."
 Q
 ;
RD ;
 N DQ,DH W ! S DIR(0)="SAO^E:EDIT;D:DELETE;C:CREATE",DIR("A")="Choose E (Edit)/D (Delete)/C (Create): "
 S DIR("?",1)="Enter 'E' to edit an existing X-reference",DIR("?",2)="      'D' to delete it",DIR("?")="      'C' to create a new X-reference."
 D ^DIR K DIR Q
 ;
Q D Q^DICE K DICD,DDA Q

DICE
DICE ;SFISC/GFT-CREATE AN XREF ;5/10/95  13:26
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %=2,DCOND="CROSS-REFERENCE" W !,"WANT TO CREATE A NEW ",DCOND," FOR THIS FIELD" D YN^DICN G Q:%-1
N F DQ=1:1 Q:'$D(^DD(DI,DA,1,DQ))
 W !,"CROSS-REFERENCE NUMBER: "_DQ_"// " R X:DTIME S:'$T DTOUT=1 G Q:'$T S:X="" X=DQ G NQ:X'?.N!'X,X:$D(^(X)) S DQ=X
 S DH=0,DIC="^DOPT(""DICR"",",DIC(0)="EQA",DIC("B")=1,DIC("S")="I 1"_$P(",Y-4",U,DUZ(0)'="@")_$P(",Y-5",U,$D(^DD(J(N),0,"LOOK"))>0)_$P(",Y-7",U,'$D(^XMB(3.6))) S:$P($G(^DD($$FNO^DILIBF(J(N)),0,"DI")),U)="Y" DIC("S")=DIC("S")_",Y-4,Y-6,Y-7"
 D ^DIC K DIC D QQ S Y=+Y G X:Y<0,6^DICE0:Y=6,^DICE7:Y=7
 G A:'N W !,"WANT TO ",DCOND," WHOLE FILE BY THIS FIELD" D YN^DICN G X:%<1 I %=1 S DH=N G A
 F DH=N-1:-1 Q:'DH  S %=1 W !,"WANT TO "_DCOND_" "_$P(^DD(J(N-DH),0),U,1)_" BY THIS FIELD" D YN^DICN G X:%<1,A:%=1
A S %=1,DIK="" I Y=1!(Y=4) W !,"WANT ",DCOND," TO BE USED FOR LOOKUP AS WELL AS FOR SORTING" D YN^DICN G X:%<1 I %=2 S DIK="A"
 I Y=2 S DIKWIC="(,.?! '-/&:;)" W !,"PARSE ON THE FOLLOWING CHARACTERS: ",DIKWIC,"//" R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X]"" DIKWIC=X I X["""" S X="?"
 I Y=2,X]"",X'?1P.P!(X?1"?"."?") W !?5,"Please enter the punctuation marks (except quotes) which will be used to ",!?5,"separate the words in this field." G A
 I Y=3 F I=0:0 S I=$O(^DD(J(N-DH),.01,1,I)) G X:I=""!(DL=.01&'DH) I $D(^(I,0)) S DE=$P(^(0),U,2) G CKF:DE?1U.UN
 I Y=4 D M G:$D(DIRUT) Q S:$D(XX(1)) X(1)=XX(1) S:$D(XX(2)) X(2)=XX(2) K XX
IX F X=$S(Y-1&(Y-3)!(DA-.01):67,1:66):1 S DE=DIK_$C(X) I '$D(^DD(J(N-DH),0,"IX",DE)) Q:DUZ(0)'="@"  W !,"INDEX: ",DE,"// " R X:DTIME S:'$T DTOUT=1 S:X]"" DE=X G Q:X[U!'$T,IX:DE'?1A.AN,IX:$D(^(DE)) Q
CKF W !,"..." S DREF=Y
 D ^DICE0 W ! D DSC,DIEZ^DIU0,F G Q
 ;
F S X=^DD(J(N),DA,1,DQ,1),%=1 I DREF=4!$D(^("CONDITION")),@("$O("_DIU_"0))>0") S %=0 W !!,"DO YOU WANT TO CROSS-REFERENCE EXISTING DATA NOW" D YN^DICN I '% W !!,"Enter 'YES' to execute the new set logic now.",!,"Otherwise, enter 'NO'." G F
 D DD^DICD:%=1 I $D(DDA),DDA="" S DDA="N" D XA^DICATTA
 K % Q
 ;
M N Y,DQ F I=1,2 S DIR(0)=".1,"_I D ^DIR Q:$D(DIRUT)  S XX(I)=X
 K DIR Q
 ;
Q D QQ K DE,DB,DREF,DCOND,DICOMPX,I,DQ,DA,DH,DIK,DIC,N,DL,J,X,Y,A,XX Q
 ;
EDT ;
 I DH(DQ,4) D R^DICD Q:'$D(DICD)  S DQ=DICD
 I $D(DDA) S DDA="E" D XS^DICATTA
 W ! F A0=1:1:2 S A1(A0)=^DD(J(N),DA,1,DQ,A0)
 S A0=DI,DR=$S(DUZ(0)="@"&($P(DH(DQ),U,3)["MUMPS"):"1:3;10",1:"3;10") D ED
 F A0=1:1:2 I A1(A0)'=^DD(J(N),DA,1,DQ,A0) S ^("DT")=DT,DREF=4 D DIEZ^DIU0,KOLD^DICD,F,D^DICD Q
 K A0,A1 I $D(DDA) D XA^DICATTA
 Q
 ;
ED S:$D(DA(1))#2 A1(3)=DA(1) S DICD=DL,DA(2)=A0,DA(1)=DA,DA=DQ,DIE="^DD("_DA(2)_","_DA(1)_",1," D DIE K DIE,DR
 S DL=DICD,DQ=DA,DA=DA(1) S:$D(A1(3)) DA(1)=A1(3) K DICD Q
 ;
DIE N J,N,DI,A1 D ^DIE Q
DSC S A0=J(N),DR="3;4///"_DT_";10" D ED K A0 Q
 ;
NQ I X'[U W $C(7),!?8,"NEVER MIND, JUST HIT THE 'RETURN'!" G N
X W $C(7),"??" G Q
 ;
QQ K ^UTILITY("DICE",$J),DBOOL,DLAY,DQI,DICOMPX,DIN,DCNEW,DFLD,DREF,DENEW,DLOC,DSUB,DHI,DOLD,DNEW,%X,V

DICE0
DICE0 ;SFISC/GFT,XAK-XREF'S ;5/24/94  2:21 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S ^DD(J(N),DA,1,0)="^.1",^(DQ,0)=J(N-DH)_U_DE,X=I(0)
 F Y=N:-1:DH+1 S X=X_"DA("_Y_"),"_I(N+1-Y)_","
 S X=X_""""_DE_""",",Y=",DA)" F %=1:1:DH S Y=",DA("_%_")"_Y
 D @DREF ;I DE'="B" K DICOMPX S DE(0)=Y(0) D COND^DICE4 S Y(0)=DE(0) I $D(DCOND) S ^(1)=X_" I X S X=DIV "_^DD(J(N),DA,1,DQ,1),^(2)=X_" I X S X=DIV "_^(2),^("CONDITION")=DCOND(0)
 S DIK="^DD(J(N),",DA(1)=J(N) D IX1^DIK
 I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ
 Q
 ;
1 S Y="$E(X,1,30)"_Y,^(2)="K "_X_Y
 S ^DD(J(N),DA,1,DQ,1)="S "_X_Y_"=""""" Q
 ;
2 S ^(0)=^(0)_"^KWIC",^(1)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2,^DD(""KWIC"")'[I S "_X_"I"_Y_"="""""
 S ^(2)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2 K "_X_"I"_Y K DIKWIC Q
 ;
3 D 1 S ^(1)="S:'$D("_X_Y_") ^(DA)=1",^(2)="I $D("_X_Y_"),^(DA) K ^(DA)",^(0)=^(0)_"^MNEMONIC" Q
 ;
4 S ^(0)=^(0)_"^MUMPS",^(1)=X(1),^(2)=X(2) K X Q
 ;
5 S ^(0)=^(0)_"^SOUNDEX",X=X_"X_I"_Y,Y="S I=$E(X,1,27) D SOU^DICM ",^(1)=Y_"S "_X_"=""""",^(2)=Y_"K "_X,(^DD(J(N),0,"LOOK"),^("QUES"))="SOUNDEX" Q
 ;
6 ;
 D ^DICE1 G Q:U[X S ^UTILITY("DICE",$J,0)="^^TRIGGER^"_DIN_U_DENEW,^("FIELD")=DCNEW
 F DIK=1,2 D ^DICE2 G M^DICATT:$D(DTOUT),Q:U=X
 I '$D(^DD(DIN,DENEW,9))!($G(^(9))="") S %=2 W !!,"WANT TO PROTECT THE '",DNEW,"' FIELD, SO THAT",!,"IT CAN'T BE CHANGED BY THE 'ENTER & EDIT' ROUTINE" D YN^DICN G QQ:%<0 S:%=1 ^(9)=U
 ;
X ;
 S DA=DL,%Y="^DD("_DI_","_DL_",1,"_DQ_",",%X="^UTILITY(""DICE"",$J," I @("$O("_%Y_"0))>0") W $C(7),!!,"HEY, WHILE WE WERE TALKING, SOMEONE ELSE CREATED CROSS-REFERENCE #"_DQ_"!!!" G Q
 D %XY^%RCR,DSC^DICE,DIEZ^DIU0 I $D(DDA) S DDA="N" D XA^DICATTA
 D:$D(^DD(J(0),0,"DIK")) D^DICD D QQ S DIK="^DD("_DI_","_DL_",1,",(DA,DREF)=DQ,DA(1)=DL,DA(2)=DI,@(DIK_"0)=U_.1") D IX1^DIK W !,"...CROSS-REFERENCE IS SET"
 S %=2 I @(DIK_DREF_",1)'=""Q"""),@("$O("_DIU_"0))>0") W !!,"DO YOU WANT TO RUN THE CROSS-REFERENCE FOR EXISTING ENTRIES NOW" D YN^DICN I %=1 S X=^DD(DI,DL,1,DQ,1) D DD^DICD
Q G Q^DICE
QQ G QQ^DICE

DICE1
DICE1 ;SFISC/XAK-TRIGGER LOGIC ;5/7/93  1:54 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FIELD S %=DI,%F=DL,DOLD=$P(^DD(DI,DL,0),U) W !!,"WHEN THE " D WR^DIDH
 R "IS CHANGED,",!,"WHAT FIELD SHOULD BE 'TRIGGERED': ",X:DTIME Q:U[X
 I X?1."?" S DIC="^DD("_DI_",",DIC(0)="QE",DIC("S")="S %=$P(^(0),U,2) I %'[""C""&(%'[""W"")",DIC("W")="W:$P(^(0),U,2) ""   (multiple)""" D ^DIC K DIC G FIELD
 F %=0:0 S %=$F(X," IN ") Q:'%  S X=$E(X,1,%-5)_":"_$E(X,%,999),%=$F(X," FILE") S:% X=$E(X,1,%-6)_$E(X,%,999)
 F %=99:0 S %=$O(I(%)) Q:%=""  K I(%),J(%)
 S %=-1,DCNEW=X,DICOMP="SW?",X="INTERNAL("_$P(X,":",1)_")"_$S($F(X,":"):":",1:"")_$P(X,":",2,99) D DA,DICOMP
 I '$D(X) S X=DCNEW,DICOMP="SW?" D DICOMP
 F %=9.2:.1 Q:'$D(X(%))  S ^UTILITY("DICE",$J,%+80)=X(%)
 I '$D(X)!'DICOMPX W !,"  ...",I,$C(7),!,"YOU MUST IDENTIFY SOME FIELD, EITHER WITHIN THE",!,"'",@("$P("_DIU_"0),U,1)"),"' FILE OR IN SOME OTHER" G FIELD
 S DFLD=X,DENEW=+$P(DICOMPX,U,2),DIN=+DICOMPX,DREF="",DLAY=Y["L"
 K X F X=Y\100*100:-100:0 F %=X:1 Q:'$D(J(%))  G CK:J(%)=DIN
 W $C(7),!,"SORRY, I AM CONFUSED" G FIELD
CK I DENEW=.001 W $C(7),!,"CAN'T UPDATE A 'NUMBER' FIELD!" G FIELD
 I DENEW=DL,DIN=DI W $C(7),!,"CAN'T HAVE A FIELD TRIGGERING ITSELF!!!" G FIELD
 S DIFILE=J(X),DIAC="DD" D ^DIAC I '% W $C(7),!,"YOU DON'T HAVE 'DATA DEFINITION' ACCESS TO",!,"  THE '",$O(^DD(J(X),0,"NM",0)),"' FILE!" G FIELD
 I $P($G(^DD(J(X),0,"DI")),U,2)["Y" W $C(7),!,"CAN'T TRIGGER A RESTRICTED"_$S($P(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE!" G FIELD
 F X=X:1 S %=X#100,DREF=DREF_I(X)_$E(",",1,%)_"DIV("_%_"),",A=X S:$S('$D(J(%)):1,1:J(%)-J(X))&'$D(DICOMPX(0,J(X))) ^UTILITY("DICE",$J,"DIC")="LOOKUP" Q:J(X)=+DICOMPX!'$D(I(X+1))
 S DLOC=$P(^DD(DIN,DENEW,0),U,4),DSUB=$P(DLOC,";",1),DLOC=$P(DLOC,";",2),DNEW=$P(^(0),U,1) S:+DSUB'=DSUB DSUB=Q_DSUB_Q
 I $P(^(0),U,2)["C" W !,$C(7),"CAN'T TRIGGER A COMPUTED FIELD!" G FIELD
 W "  ...OK" K DIFILE,DIAC Q
 ;
DA S DA="^DD("_DI_","_DL_",1,"_DQ_","_8 Q
 ;
DICOMP ;
 S DICOMPX="",DICOMPX(0)="DIV(",DQI="Y(" G ^DICOMP
 ;

DICE2
DICE2 ;SFISC/GFT-TRIGGER LOGIC ;6/2/89  10:31
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:$D(DTOUT)  W !!!,"---",$P("SET^KILL",U,DIK)," LOGIC---" S DA="^DD("_DI_","_DL_",1,"_DQ_","_(DIK+3)
C K DICOMPX,DATE S:DOLD=DNEW DNEW="TRIGGERED "_DNEW S DNEW=$E(DNEW,1,30),DICOMPX(DNEW)="DIU",DICOMPX(DNEW,U)=DIN_U_DENEW,DCOND="SET" S:$P(^DD(DIN,DENEW,0),U,2)["D" DICOMPX(DNEW,"DATE")=1
 W !!,"IN ANSWERING THE FOLLOWING QUESTION, '"_DNEW_"'",!?2,"CAN BE USED TO REFER TO THE EXISTING TRIGGERED FIELD VALUE.",!
 S DICOMP="?",DICOMPX="",%=DIN S:DIK=1 DICOMPX(1,DI,DL)="DIV"
 D OLD W "PLEASE ENTER AN EXPRESSION WHICH WILL BECOME THE VALUE OF THE",! S %F=DENEW D WR^DIDH
 D GET Q:U[X  I X="""@""" K X G DICE2^DIQQ
 I X="@" S X="S X="""""
 E  D ^DICOMP G DICE2^DIQQ:'$D(X) F %=9.2:.1 Q:'$D(X(%))  S ^UTILITY("DICE",$J,DIK+3*10+%)=X(%)
 K DICOMPX(DNEW) I X="S X=""""" S DE=X,DCOND="DELE" D DEL^DICE3 G Q:X=U,^DICE4:DENEW-.01 F X=0:1 G D01:'$D(J(X)) I J(X)=DIN W $C(7),!,"BUT THE TRIGGERING FIELD DEPENDS ON THE TRIGGERED FIELD!" S X=U G Q
 S DE="S X=DIV "_X,%=$P(^DD(DIN,DENEW,0),U,2) I %["D",'Y["D" W $C(7),!,"WARNING -- THIS SHOULD PRODUCE A DATE VALUE, AND IT MAY NOT!"
 S V=$P(%,"P",2) I V,DICOMPX-V!($P(DICOMPX,U,2)-.001) W !,$C(7),"WARNING -- THIS MUST BE '",$P(^DIC(+V,0),U,1)," NUMBER'!"
 I Y["B" W $C(7),!,"WARNING--THIS TRUTH-VALUED EXPRESSION WILL PRODUCE ONLY VALUES OF '0' OR '1'"
 I %'["D",Y["D" W $C(7),!,"WARNING -- THIS MAY PRODUCE A 'DATE', AND IT SHOULDN'T!"
 D ^DICE3 G ^DICE4:X'=U
Q Q
 ;
OLD ;
 I DIK=2 S X=$E("OLD "_DOLD,1,30),DICOMPX(X)="X",DICOMPX(X,U)=DI_U_DL W ?2,"NOTE: '"_X_"' CAN BE USED TO REFER TO THE VALUE OF THE",!?2,DOLD_" FIELD BEFORE ITS CHANGE OR DELETION.",! S:$P(^DD(DI,DL,0),U,2)["D" DICOMPX(X,"DATE")=1
 Q
 ;
D01 S V=DREF,X=$L(V)-1 F %=X:-1 I "(,"[$E(V,%) S DHI=$E(V,%+1,X) I DHI'?1N1")" S V=$E(V,1,%),X=0 Q
DQ S X=$F(V,Q,X) I X>0 S V=$E(V,1,X-1)_Q_$E(V,X,999),X=X+2 G DQ
 S X="I "_DHI_">0 S DIK(0)=DA,",V="DIK="""_V_""",",DHI="DA="_DHI_" D ^DIK",DTAG="S DA=DIK(0)"
 F %=1:1:N S X=X_"DIK("_%_")=DA("_%_"),",DTAG=DTAG_",DA("_%_")=DIK("_%_")"
 F %=1:1:A#100 S DHI="DA("_%_")=DIV("_(A#100-%)_"),"_DHI
 S X=X_V_DHI,DTAG=DTAG_" K DIK",^UTILITY("DICE",$J,"DIK")="DELETE" G F^DICE4
 ;
GET ;
 W !," WHENEVER THE '"_DOLD_"' FIELD IS "_$P("ENTERED OR CHANGED^CHANGED OR DELETED",U,DIK)
 R ": ",X:DTIME S:'$T X=U S Y=X I X="" S Y="NO EFFECT",^UTILITY("DICE",$J,DIK)="Q" W "  ",Y I DIK=2,^UTILITY("DICE",$J,1)="Q" W $C(7),"??" S X=U
 S ^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE VALUE")=Y

DICE3
DICE3 ;SFISC/GFT-TRIGGER LOGIC ;8/14/89  12:37
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G DIU:DIK=1
 ;
DEL ;
 G DIU:'DLAY
 W !!,$C(7),"ARE YOU SURE YOU WANT TO 'ADD A NEW ENTRY' WHEN THIS "_$P("SET^KILL",U,DIK)_" LOGIC OCCURS"
 S %=2 D YN^DICN W ! I %<1 S X=U Q
 G DIU:%=1 W "..OK, LET ME THINK A SECOND...",! S X=DCNEW,DICOMP="",DA="^DD("_DI_","_DL_",1,"_DQ_","_9 D DICOMP^DICE1
 S DFLD=X F %=9.2:.1 Q:'$D(X(%))  S ^UTILITY("DICE",$J,90+%)=X(%)
DIU S Y=DFLD_" S DIU=X K Y",DA="^DD("_DI_","_DL_",1,"_DQ_","

DICE4
DICE4 ;SFISC/GFT-TRIGGER LOGIC ;2/17/93 12:08 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D SET S DTAG="S DIH=$S($D("_DREF_DSUB_")):^("_DSUB_"),1:""""),DIV=X "_$P("I $D(^(0)) ",Q,A>99)_X_",DIH="_DIN_",DIG="_DENEW_" D ^DICR:$O(^DD(DIH,DIG,1,0))>0",X=""
 S:$L(DE)+$L(DTAG)>160&($L(DE)>30) ^UTILITY("DICE",$J,DIK+.1)=DE,DE="X "_DA_DIK_".1)" S X=DE
F ;
 S DB=DA_DIK
 S:$L(Y)+$L(X)>190 ^UTILITY("DICE",$J,DIK+.2)=Y,Y="X "_DB_".2)" S:$L(Y) X=Y_" "_X
 K DICOMPX(DNEW) S DHI=X,DCOND=DCOND_"TING OF '"_DNEW_"'" D COND G P:'$D(DCOND) I DLAY,DICOMPX,DICOMPX-DI W !,"SORRY, CAN'T DO THIS WHEN 'LAYGO' ALLOWED" S X=U Q
 S DHI="I X S X=DIV "_DHI I $O(J(A))>0 S ^("DIC")=""
P S:$L(DHI)+$L(X)>220 ^UTILITY("DICE",$J,DIK+.3)=X,X="X "_DB_".3)" S X=X_" "_DHI
 S:$L(DTAG)+$L(X)>225 ^UTILITY("DICE",$J,DIK+.4)=DTAG,DTAG="X "_DB_".4)" S ^UTILITY("DICE",$J,DIK)=X_" "_DTAG K DTAG,D Q
 ;
SET G PIECE:DLOC S DHI=$P(DLOC,",",2),%=+$E(DLOC,2,9),X="S DE="_(%-1)_"-$L(DIH),DIU=$E(DIH,"_%_","_DHI_"),Y=$E(DIH,"_(DHI+1)_",999),^("_DSUB_")="
 I %>1 S X=X_"$E(DIH,1,"_(%-1)_")_"
 S X=X_"$J("""",$S(DE>0:DE,1:0))_DIV_$S(Y?."" "":"""",1:$J("""","_(DHI-%+1)_"-$L(DIV))_Y)" Q
PIECE S X="S $P(^("_DSUB_"),U,"_DLOC_")=DIV" Q
 ;
COND S DE=" DIV=X" F %=0:1:N S DE=DE_",D"_%_"=DA"_$S(%=N:"",1:"("_(N-%)_")") I A#100'<% S DE=DE_",DIV("_%_")=D"_%
 D CC I $D(DCOND) S DE=DE_" "_X
 S X="K DIV S"_DE
Q Q
 ;
CC ;
 S DA=DA_(DIK+5)
R W !!,"DO YOU WANT TO MAKE THE "_DCOND_" CONDITIONAL" K DICOMPX S %=2,DICOMPX="",DICOMP="?X",D="ENTER AN EXPRESSION FOR THE CONDITION: " D YN^DICN I %-1 K DCOND Q
 I DIK=1 S DICOMPX("Y(0)")="Y(0)",DICOMPX(1,DI,DL)="Y(0)",DICOMPX("Y(0)",U)=DI_U_DL
 E  W ! D OLD^DICE2 S Y="CREATE CONDITION" I $D(^UTILITY("DICE",$J,Y)) W !,D_^(Y)_"// " R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X="" X=^(Y) G X
 W !,D R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T
X I X?."?" W !,"ENTER A TRUTH-VALUED 'COMPUTED-FIELD' EXPRESSION ",!?4,"(PERHAPS INVOLVING '"_DOLD_"')" G R
 S DCOND(0)=X D ^DICOMP I $D(X) W:Y'["B" !,"WARNING--THIS DOESN'T LOOK LIKE A CONDITION EXPRESSION!" S X="S Y(0)=X "_X,^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE CONDITION")=DCOND(0) F %=9.2:.1 G Q:'$D(X(%)) S ^(DIK+5*10+%)=X(%) K X(%)
 W $C(7),"??" G R

DICE7
DICE7 ;SFISC/GFT-BULLETIN X-REFS ;2/17/93 12:10 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY("DICE",$J) S ^($J,0)="^^BULLETIN MESSAGE",DOLD=$P(^DD(DI,DL,0),U,1)
 F DIK=1,2 Q:$D(DTOUT)  D M G QQ:X[U!$D(DTOUT) I X]"" S DQI="Y(",DCOND="SENDING OF '"_DREF_"'" D DA,CC^DICE4,DA G QQ:$D(DTOUT) S DHI=0,DLAY=$S($D(DCOND):X,1:"") D S G QQ:X=U
 Q:$D(DTOUT)  G X^DICE0
QQ G QQ^DICE
 ;
DA S DA="^DD("_DI_","_DL_",1,"_DQ_"," Q
 ;
M W !!!,"---"_$P("SET^KILL",U,DIK)_" LOGIC---",!!,"ENTER THE NAME OF A 'BULLETIN' MESSAGE, IF YOU WANT THAT MESSAGE SENT"
 D GET^DICE2 Q:U[X  S DIC=3.6,DIC(0)="ELMQ",DIC("DR")=".01;2;4;11;10" D ^DIC K DIC,DICOMPX G M:Y<0
 S (DREF,^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE VALUE"))=$P(Y,U,2),DCOND=DI_U_DL_U_DIK_U_DQ
 S DIE=3.6,DA=+Y,DR=10 D:'$P(Y,U,3) ^DIE S X=DREF,DI=$P(DCOND,U,1),DL=$P(DCOND,U,2),DIK=$P(DCOND,U,3),DQ=$P(DCOND,U,4) Q
 ;
S W "  ..OK",! S DHI=DHI+1
SS S DLOC="PARAMETER #"_DHI I DHI>1 W !,"NOW, IF THE BULLETIN IS TO HAVE "_DHI_" OR MORE PARAMETERS INSERTED,"
 W !,"ENTER A FIELD NAME (FOR EXAMPLE, '"_DOLD_"'),",!,"OR A 'COMPUTED-FIELD' EXPRESSION,",!,"THE VALUE OF WHICH WILL BE PASSED INTO THE '"_DREF_"' MESSAGE,",!,"AS "_DLOC
 S X=$O(^XMB(3.6,"B",DREF,0)) S:X="" X=-1 I X F Y=1:1 Q:'$D(^XMB(3.6,X,4,Y,0))  I ^(0)=DHI F D=1:1 G T:'$D(^XMB(3.6,X,4,Y,1,D,0)) W !?4,"-- ",^(0)
 W !,"(NOTE THAT NO SUCH PARAMETER IS DEFINED FOR THE '"_DREF_"' BULLETIN)"
T W ! D OLD^DICE2 W DLOC_": " R X:DTIME S:'$T DTOUT=1 G:X?.P QQ:X=U!'$T,SET:X="",SS S DSUB=X,DICOMP="?" D ^DICOMP I $D(X)-1 W $C(7),"??",! G SS
 S DHI(DHI)=X_$P(" S Y=X X ^DD(""DD"") S X=Y",1,Y["D"),^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE "_DLOC)=DSUB G S
SET W ! S ^UTILITY("DICE",$J,DIK)="K XMY S XMB="""_DREF_""" D ^XMB:$D(^XMB(3.6,""B"",XMB)) K Y,XMB",Y="",DHI=185-(DHI*20)
 F D=1:1 Q:'$D(DHI(D))  S X="S X=Y(0) "_DHI(D)_" S XMB("_D_")=X" S:$L(DREF)+$L(X)+$L(Y)>DHI %=DIK_"."_D,^(%)=X,X="X "_DA_%_")" S Y=Y_" "_X
 S I="S Y(0)=X,D"_N_"=DA" F %=1:1:N S I=I_",D"_(N-%)_"=DA("_%_")"
 I $L(DLAY) S Y=" I X"_Y S:$L(I)+$L(Y)+$L(DLAY)+$L(^(DIK))>238 ^(DIK+.9)=DLAY,DLAY="X "_DA_(DIK+.9)_")" S DLAY=" "_DLAY
 S:Y]""!$T ^(DIK)=I_DLAY_Y_" "_^(DIK)

DICF
DICF ;SEA/TOAD-VA FileMan: Finder, Part 1 (Main) ;9/5/96  14:28
 ;;21.0;VA FileMan;**17,27**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12162;7062808;4828;
 
FIND(DIFILE,DIEN,DIFLDS,DIFLAGS,DIVALUE,DIMAX,DIFORCE,DISCREEN,DID,DILIST,DIMSGA) 
 ; ENTRY POINT--silent selecter
 ; subroutine, DIFORCE passed by reference
 
FINDX ; branch in from FIND^DIC
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
 N DA,DICOUNT,DIFAIL,DIROOT
 I $G(DIFLAGS)'["p"!($G(DIFLAGS)["l") N DILVA
 S (DICOUNT,DICOUNT(0))=+$G(DILIST("C"))
 S DICOUNT("LOOK")=0
 S DICOUNT("MORE")=0
 S DICOUNT("MAX")=$G(DIMAX) I DICOUNT("MAX")="" S DICOUNT("MAX")="*"
 S DILIST(0)=$G(DILIST(0)) I DILIST(0)<1 S DILIST(0)=1
 
INPUT 
 S DIFAIL=0 D  I DIFAIL D CLOSE Q
I0 . ; flags
 . S DIFLAGS=$G(DIFLAGS)
 . I DIFLAGS["O",DIFLAGS["X" S DIFLAGS=$TR(DIFLAGS,"O")
 . I DIFLAGS'["p" S DIFLAGS=DIFLAGS_"t"
 . I DIFLAGS["p" S DIFLAGS=DIFLAGS_"f"
I1 . ; value
 . S DIVALUE=$G(DIVALUE)
I2 . ; target_root
 . S DILIST=$G(DILIST)
 . I DILIST'="" I DIFLAGS'["v" K @DILIST
 . I DILIST'="",DIFLAGS'["f" S DILIST=$NA(@DILIST@("DILIST"))
 . I DILIST="" S DILIST="^TMP(""DILIST"",$J)" I DIFLAGS'["v" K @DILIST
 . S DILIST("LVA")=$G(DILIST("LVA"))
 . I DILIST("LVA")="" S DILIST("LVA")="DILVA"
 . I DIFLAGS["p",DIVALUE'="",$G(@DILIST("LVA")@("V"))="" D
 . . S DIFLAGS=DIFLAGS_"t"
I3 . ; file
 . S DIFILE=$G(DIFILE) I 'DIFILE S DIFAIL=1 D  Q
 . . D ERR^DICF6(202,"","","","FILE")
 . N DINODE S DINODE=$G(^DD(DIFILE,.01,0))
 . I DINODE="" S DIFAIL=1 D  Q
 . . D ERR^DICF6($S('$D(^DD(DIFILE)):401,1:406),DIFILE)
 . I $P(DINODE,U,2)["W" S DIFAIL=1 D ERR^DICF6(407,DIFILE) Q
I4 . ; IENS
 . S DIEN=$G(DIEN) I DIEN="" S DIEN=","
 . I '$$IEN^DIDU1(DIEN) S DIFAIL=1 D  Q
 . . I '$$IEN^DIDU1(DIEN_",") D ERR^DICF6(202,"","","","IENS") Q
 . . E  D ERR^DICF6(304,"",DIEN) Q
 . I $P(DIEN,",")'="" S DIFAIL=1 D ERR^DICF6(306,"",DIEN) Q
 . I DIEN["," D DA^DILF(DIEN,.DA) S DA=DIEN M DIEN=DA
I5 . ; file root
 . S DIROOT=$$ROOT^DIQGU(DIFILE,DIEN,1,1) I $G(DIERR) S DIFAIL=1 Q
 . I DIROOT="" S DIFAIL=1 D  Q
 . . D ERR^DICF6(402,DIFILE,DIEN)
 . I $O(@DIROOT@(0))'>0 S DIFAIL=1 Q
 . S DIROOT("O")=$$OREF^DIQGU(DIROOT)
 . I DIFLAGS["v" S DIROOT("V")=DIROOT("O"),$E(DIROOT("V"))=";"
 . I DIVALUE=" " S DIROOT("Q")=$$ROOT^DIQGU(DIFILE,DIEN,"Q")
I6 . ; fields
 . S DIFLDS=$G(DIFLDS)
I7 . ; flags again
 . I $TR(DIFLAGS,"AMOPQSUXfglpqtuv")'="" S DIFAIL=1 D  Q
 . . D ERR^DICF6(301,"","","",$TR(DIFLAGS,"fglpqtuv"))
 . I $O(@DIROOT@("A["))="" S DIFLAGS=DIFLAGS_"u"
I8 . ; forced indexes
 . S DIFORCE=$G(DIFORCE)
 . I "*"[DIFORCE S DIFORCE=0,DIFORCE(0)="*"
 . E  I DIFORCE="#" S DIFORCE=0,DIFORCE(0)="#",DIFLAGS=DIFLAGS_"u"
 . E  D  I DIFAIL D ERR^DICF6(202,"","","","Indexes") Q
 . . S DIFORCE(0)=$G(DIFORCE)
 . . I $P(DIFORCE(0),U)="" S DIFAIL=1 Q
 . . S DIFLAGS=DIFLAGS_"M"
 . . S DIFORCE=1
I9 . ; rest
 . I DICOUNT("MAX")'="*" D  Q:DIFAIL
 . . I DICOUNT("MAX")\1=DICOUNT("MAX"),DICOUNT("MAX")>0 Q
 . . S DIFAIL=1 D ERR^DICF6(202,"","","","Number")
 . S DISCREEN=$G(DISCREEN)
 . I DIFLAGS["U" S DISCREEN("F")=""
 . E  I $P($G(@DIROOT@(0)),U,2)'["s" S DISCREEN("F")=""
 . E  S DISCREEN("F")=$G(^DD(DIFILE,0,"SCR"))
 . S DID=$G(DID)
 
HOOK75 
 N DIHOOK75,DIOUT
 S DIHOOK75=$G(^DD(DIFILE,.01,7.5))
 S DIOUT=0
 I DIHOOK75'="",U'[DIVALUE,DIVALUE'?."?" D  I DIOUT D CLOSE Q
 . N %,D,DIC,X,Y,Y1
 . S D=DIFORCE(0)
 . S DIC=DIFILE
 . S DIC(0)=$TR(DIFLAGS,"fglpqtuv")
 . S X=DIVALUE
 . M Y=DIEN S Y=""
 . S Y1=DIEN
 . X DIHOOK75 I '$D(X)!$G(DIERR) S DIOUT=1 D:$G(DIERR)  Q
 . . D ERR^DICF6(120,DIFILE,"",.01,"Pre-lookup Transform (7.5 node)")
 . S DIVALUE=X
 . I $G(DIC("S"))'="" S DISCREEN=DIC("S")
 . I $G(DIC("V"))'="" S DISCREEN("V")=DIC("V")
 
LOOKUP 
 N DIDENT
 I DIFLAGS'["f" D  I $G(DIERR) D CLOSE Q
 . D IDENTS^DICU1(DIFILE,.01,.DIROOT,DIFLDS,DID,.DIDENT)
 I DIFLAGS'["p" D SPECIAL^DICF1(DIFILE,.DIEN,DIFLAGS,.DIROOT,DIVALUE,DIFORCE(0),.DICOUNT,.DIFAIL,.DISCREEN,.DIDENT,.DIOUT,.DILIST)
 I DIOUT D CLOSE Q
 I DIFLAGS["t" D
 . D XFORM^DICF1(.DIFLAGS,.DIVALUE,.DISCREEN,.DILVA,.DILIST)
 I DIFLAGS["u" ;D UPRIGHT^DICF4(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,.DICOUNT,.DISCREEN,.DIDENT,.DILIST) I 1
 E  D CHKALL^DICF2(.DIFILE,.DIEN,DIFLAGS,.DIROOT,.DIVALUE,.DICOUNT,.DISCREEN,.DIFORCE,.DIDENT,.DILIST)
 D CLOSE
 Q
 
CLOSE 
 ; cleanup
 I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
 I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 I '$G(DIERR),DIFLAGS'["p" S @DILIST@(0)=DICOUNT_U_DICOUNT("MAX")_U_DICOUNT("MORE")
 I DILIST'="" K @DILIST@("B")
 K ^TMP("DILVA",$J,DILIST(0))
 I DILIST(0)=1 K ^TMP("DILVA",$J)
 S DILIST("C")=DICOUNT
 Q
 

DICF1
DICF1 ;SEA/TOAD-VA FileMan: Finder, Part 2 (Transform) ;11/17/94  12:21 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
XFORM(DIFLAGS,DIVALUE,DISCREEN,DILVA,DILIST) 
 ; FIND--produce array of values and screens by transforming input
 ; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
BASIC 
 N DISNAME S DISNAME="DILVA(""S"")"
 N DIVNAME S DIVNAME="DILVA(""V"")"
 S @DIVNAME=DIVALUE
 S @DISNAME=DISCREEN
SETLONG 
 N DILONG S DILONG=$S(DIFLAGS["Q":0,1:$L(DIVALUE)>29&(DIFLAGS'["U")*4)
 I DILONG N DISNAMES S DISNAMES=DISNAME,DISNAME=$NA(@DISNAME@(0))
 N DISNAMEX S DISNAMEX=$NA(@DILIST("LVA")@("S"))
 I DILONG S DISNAMEX=$NA(@DISNAMEX@(0))
 I DILONG N DIVNAMES S DIVNAMES=DIVNAME,DIVNAME=$NA(@DIVNAME@(0))
 N DIVNAMEX S DIVNAMEX=$NA(@DILIST("LVA")@("V"))
 I DILONG S DIVNAMEX=$NA(@DIVNAMEX@(0))
 S @DIVNAME@(1+DILONG)=DIVALUE
 S @DISNAME@(1+DILONG)=DISCREEN
 I DIFLAGS["Q" Q
LOWER 
 I DIVALUE?.E1L.E N DILOWER,DIUPPER D
 . S DILOWER="abcdefghijklmnopqrstuvwxyz"
 . S DIUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 . N DITEMP S DITEMP=$TR(DIVALUE,DILOWER,DIUPPER)
 . S @DIVNAME@(2+DILONG)=DITEMP
 . S @DISNAME@(2+DILONG)=DISCREEN
 
COMMA N DIREF I DIVALUE[",",DIFLAGS'["X" D
 . S DIFLAGS=DIFLAGS_"g"
 . N DISTEMP S DISTEMP=""
 . N DIPART1 S DIPART1=" I %?.E1P1"""
 . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1"""
 . N DIPART3 S DIPART3=""".E))"
 . N DIOUT S DIOUT=0
21 . N DIPIECE,DIVPIECE F DIPIECE=2:1 D  I DIOUT Q
 . . S DIVPIECE=$P(DIVALUE,",",DIPIECE)
 . . I DIVPIECE["""" Q
 . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE))
 . . I DIVPIECE="" S DIOUT=1 Q
 . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q
 . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
22 . I DISTEMP="" Q
 . S DISTEMP="S %=DIFIELD"_DISTEMP
 . S DIREF=$NA(@DISNAMEX@(1+DILONG))
 . N DISOLD I @DIREF="" S DISOLD=""
 . E  S DISOLD=" X "_DIREF
 . S @DIVNAME@(3+DILONG)=$P(DIVALUE,",")
 . S @DISNAME@(3+DILONG)=DISTEMP_DISOLD
23 . I DIVALUE'?.E1L.E Q
 . S DIREF=$NA(@DISNAMEX@(2+DILONG))
 . I @DIREF="" S DISOLD=""
 . E  S DISOLD=" X "_DIREF
 . S @DIVNAME@(4+DILONG)=$TR($P(DIVALUE,","),DILOWER,DIUPPER)
 . S @DISNAME@(4+DILONG)=$TR(DISTEMP,DILOWER,DIUPPER)_DISOLD
 
LONG I 'DILONG Q
 I DIFLAGS'["g" S DIFLAGS=DIFLAGS_"g"
 N DINODE,DISLONG,DISPART,DISXACT
 F DINODE=5:1:8 I $D(@DIVNAME@(DINODE))#2 D
 . S @DIVNAMES@(DINODE)=$E(@DIVNAME@(DINODE),1,30)
 . S DIREF=$NA(@DISNAMEX@(DINODE))
 . I @DIREF="" S DISLONG=""
 . E  S DISLONG=" X "_DIREF
 . S DIREF=$NA(@DIVNAMEX@(DINODE))
 . S DISPART="I $P(DIFIELD,"_DIREF_")="""""_DISLONG
 . S DISXACT="I $P(DIFIELD,U)="_DIREF_DISLONG
L10 . I DIFLAGS["X" S @DISNAMES@(DINODE)=DISXACT Q
 . I DIFLAGS'["O" S @DISNAMES@(DINODE)=DISPART Q
 . S @DISNAMES@(DINODE)=DISXACT
 . S @DISNAMES@(DINODE,2)=DISPART
 Q
 
SPECIAL(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DIFAIL,DISCREEN,DIDENT,DIOUT,DILIST) 
 ; FIND--check the pick value for special formats
 ; proc, DICOUNT, DIDENT, & DIFAIL by reference
 S DIOUT=0
 I U[DIVALUE S DIFAIL=1,DIOUT=1 Q
 I DIVALUE'?.ANP S DIFAIL=1,DIOUT=1 D ERR^DICF6(204,"","","",DIVALUE) Q
11 I DIVALUE=" " D  S DIOUT=1 Q
 . N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT("Q"),1,28)))
 . N DINODEL S DINODEL=$L(DINODE,",")
 . I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT("Q"),29,9999) S DIFAIL=1 Q
 . N DIENTRY S DIENTRY=$P(DINODE,",",DINODEL)
 . I 'DIENTRY S DIFAIL=1 Q
 . S DIEN=DIENTRY_DIEN
 . D ENTRY
 . I DICOUNT'>DICOUNT(0) S DIFAIL=1 Q
12 I DIVALUE?1"`"1.N D  S DIOUT=1 Q
 . N DIENTRY S DIENTRY=$E(DIVALUE,2,$L(DIVALUE))
 . S DIEN=DIENTRY_DIEN
 . D ENTRY
 . S $P(DIEN,",")=""
 . I DICOUNT'>DICOUNT(0) S DIFAIL=1
13 I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D  Q:DICOUNT>DICOUNT(0)
 . N DI001 S DI001=$D(^DD(DIFILE,.001))
 . N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2)
 . I $D(@DIROOT@(DIVALUE)) D  I DICOUNT>DICOUNT(0) Q
 . . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIROOT@("A["))'="") Q
 . . S DIEN=DIVALUE_DIEN
 . . D ENTRY
 . . S $P(DIEN,",")=""
 . . I DIFLAGS["q" S DIOUT=1
 Q
 
ENTRY D ENTRY^DICF3(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 Q

DICF2
DICF2 ;SEA/TOAD-VA FileMan: Finder, Part 3 (All Indexes) ;9/6/96  15:53
 ;;21.0;VA FileMan;**27**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12163;5355774;4384;
 
CHKALL(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DICOUNT,DISCREEN,DIFORCE,DIDENT,DILIST) 
 ; FIND--central selection engine, check all indexes for matches
 ; subroutine, DIFILE, DIFLAGS, & DIROOT passed by value
 N DIFNODE,DIFPIECE,DINDEX
 I DIFORCE S DINDEX=$P(DIFORCE(0),U),DIFNODE=0,DIFPIECE=1
 E  S DINDEX="B"
 N DIOUT S DIOUT=0
 I DIFLAGS["O" S DIFLAGS=DIFLAGS_"X"
 N DISKIP
41 F  D  Q:DIFLAGS["q"!$G(DIERR)  I DIOUT D DECIDE(.DIFLAGS,.DINDEX,.DIFORCE,DICOUNT,.DIOUT,.DILIST) Q:DIOUT
 . S DISKIP=0
 . N DILINK S DILINK=DIFILE_U_DINDEX
 . I '$D(DIFILE("CHAIN",DILINK)) D  K DIFILE("CHAIN",DILINK)
 . . S DIFILE("CHAIN",DILINK)=""
 . . D PREPIX(.DIFILE,DIFLAGS,.DINDEX,.DISKIP,.DILIST)
 . . I 'DISKIP D CHKONE^DICF3(DIFILE,.DIEN,.DIFLAGS,.DIROOT,DIVALUE,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . . I DIFLAGS["q" S DIOUT=1 Q
 . . D CLEANIX(.DINDEX,.DILIST)
43 . . I DIFLAGS'["M" S DIOUT=1 Q
 . D NXTINDX(.DIROOT,.DINDEX,.DIFORCE,.DIFNODE,.DIFPIECE)
 . I DINDEX="" S DIOUT=1
 Q
 
PREPIX(DIFILE,DIFLAGS,DINDEX,DISKIP,DILIST) 
 ; CHKALL--lookup index type, add transform values to LVA
 ; proc, DINDEX passed by ref
 K DINDEX(0,"GET")
 S DINDEX(0,"COUNT")=0
 S DINDEX(0,"TYPE")="F"
 N DIXFILE S DIXFILE=$O(^DD(DIFILE,0,"IX",DINDEX,0))
 I DIXFILE="" Q
 S DINDEX(0,"FILE")=DIXFILE
 N DIXFIELD S DIXFIELD=$O(^DD(DIFILE,0,"IX",DINDEX,DIXFILE,0))
50 I DIXFIELD="" Q
 S DINDEX(0,"FIELD")=DIXFIELD
 N DIVAL S DIVAL=@DILIST("LVA")@("V")
 S DINDEX(0,"DEF")=$G(^DD(DIXFILE,DIXFIELD,0))
51 I DINDEX(0,"DEF")="" Q
 I DIFLAGS["g" D
 . S DINDEX(0,"GET")=$$FIELD^DICU1(DIXFILE,DIXFIELD,.DINDEX)
 N DISOUNDX S DISOUNDX=DIFLAGS'["Q" I DISOUNDX D
 . S DISOUNDX=$G(^DD(DIXFILE,0,"LOOK"))="SOUNDEX" Q:'DISOUNDX
 . S DISOUNDX=$$ISSNDX^DICF4(DIXFILE,DIXFIELD,DINDEX) Q:'DISOUNDX
 N DIXFLAG S DIXFLAG=$P(DINDEX(0,"DEF"),U,2)
 I $S(DIFLAGS["Q":1,DISOUNDX:0,DIXFLAG["F":1,1:DIXFLAG["N") Q
 S DINDEX(0,"FIRST")=10
 S DINDEX(0,"LAST")=9
 S DINDEX(0,"TYPE")=DIXFLAG
52 I DISOUNDX D  Q
 . D ADDVAL($$SOUNDEX^DICF4(@DILIST("LVA")@("V")),.DINDEX,.DILIST)
 I DIXFLAG["D" D PREPD(.DINDEX,.DILIST) Q
 I DIXFLAG["S" D PREPS^DICF6(DIFLAGS,.DINDEX,.DILIST) Q
 I DIXFLAG["P" D  Q
 . D PREPP^DICF5(.DIFILE,DIFLAGS,.DINDEX,"P",.DISKIP,.DILIST)
 I DIXFLAG["V" D  Q
 . D PREPP^DICF5(.DIFILE,DIFLAGS,.DINDEX,"VP",.DISKIP,.DILIST)
 Q
 
PREPD(DINDEX,DILIST) 
 ; PREPIX--transform value for indexed date field
 ; proc, DINDEX passed by ref
 N DIFLAGS S DIFLAGS=$P($P(DINDEX(0,"DEF"),"%DT=""",2),"""")
 N DIDATEFM
 D DT^DILF($TR(DIFLAGS,"ER")_"Ne",@DILIST("LVA")@("V"),.DIDATEFM)
 I DIDATEFM'>1 Q
 D ADDVAL(DIDATEFM,.DINDEX,.DILIST)
 Q
 
ADDVAL(DINEWVAL,DINDEX,DILIST) 
 ; PREP*--add a new lookup value to the LVA
 ; proc, DINDEX passed by ref
 S DINDEX(0,"COUNT")=DINDEX(0,"COUNT")+1
 S DINDEX(0,"LAST")=DINDEX(0,"LAST")+1
 S @DILIST("LVA")@("V",DINDEX(0,"LAST"))=DINEWVAL
 S @DILIST("LVA")@("V",DINDEX(0,"LAST"),1)=1
 S @DILIST("LVA")@("S",DINDEX(0,"LAST"))=@DILIST("LVA")@("S")
 Q
 
CLEANIX(DINDEX,DILIST) 
 ; CHKALL--clear DINDEX & LVA of index data
 ; proc, DINDEX passed by ref
 I DINDEX(0,"TYPE")["P"!(DINDEX(0,"TYPE")["V") D
 . K @DILIST("LVA")
 . S DILIST("LVA")=DILIST("SAVE")
 . K DILIST("SAVE")
 I 'DINDEX(0,"COUNT") K DINDEX(0) Q
 N DIKILL F DIKILL=DINDEX(0,"FIRST"):1:DINDEX(0,"LAST") D
 . K @DILIST("LVA")@("V",DIKILL),@DILIST("LVA")@("S",DIKILL)
 K DINDEX(0)
 Q
 
NXTINDX(DIROOT,DINDEX,DIFORCE,DIFNODE,DIFPIECE) 
 ; CHKALL--return next index to try
 ; subroutine, DIROOT passed by value
 I 'DIFORCE S DINDEX=$O(@DIROOT@(DINDEX)) Q
 S DIFPIECE=DIFPIECE+1
 S DINDEX=$P(DIFORCE(DIFNODE),U,DIFPIECE)
 Q
 
DECIDE(DIFLAGS,DINDEX,DIFORCE,DICOUNT,DIOUT,DILIST) 
 ; CHKALL--if O needs to repeat: reset flags, starting index, & exit flag
 ; subroutine, DICOUNT passed by value
 I DIFLAGS'["O" Q
 I DICOUNT Q
 S DIFLAGS=$TR(DIFLAGS,"OX")
 N DINODE,DISCRPRT
 S DINODE=0 F  S DINODE=$O(@DILIST("LVA")@("V",DINODE)) Q:DINODE=""  D
 . S DISCRPRT=$G(@DILIST("LVA")@("S",DINODE,2))
 . I DISCRPRT="" Q
D1 . S @DILIST("LVA")@("S",DINODE)=DISCRPRT
 I 'DIFORCE S DINDEX="B"
 E  S DINDEX=$P(DIFORCE(0),U)
 S DIOUT=0
 Q

DICF3
DICF3 ;SEA/TOAD-VA FileMan: Finder, Part 3 (One Index) ;4/12/95  13:50 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11771;6296720;
 
CHKONE(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; CHKALL--check one index for possible matches
 ; proc, DIFILE, DIFLAGS, & DIROOT by value
 N DIXFORM S DIXFORM=0
 N DIBEFORE S DIBEFORE=DICOUNT
 N DIEXTRNL,DITRY F  D  Q:DIXFORM=""
 . S DIXFORM=$O(@DILIST("LVA")@("V",DIXFORM)) I DIXFORM="" Q
 . S DIVALUE=@DILIST("LVA")@("V",DIXFORM)
 . S DISCREEN=$G(@DILIST("LVA")@("S",DIXFORM))
 . I DISCREEN="" S DISCREEN=@DILIST("LVA")@("S")
C1 . S DITRY=1
 . I DITRY D
 . . D EXACT(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . . I DIFLAGS["q" S DIXFORM="" Q
 . . I DIFLAGS["X" Q
 . . I DINDEX(0,"TYPE")["P" Q
 . . I DINDEX(0,"TYPE")["D",DIVALUE?.NP,+DIVALUE=DIVALUE D  Q:'DIEXTRNL
C2 . . . S DIEXTRNL=$G(@DILIST("LVA")@("V",DIXFORM,1))
 . . D PARTIAL(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . . I DIFLAGS["q" S DIXFORM=""
 ; S DIVALUE=@DILIST("SAVE")@("V")
 I DICOUNT=DIBEFORE,$O(@DIROOT@(DINDEX,""))="",$O(@DIROOT@(0)) D  Q
 . D ERR^DICF6(420,DIFILE,"","",DINDEX)
 Q
 
PARTIAL(DIFILE,DIEN,DIFLAGS,DIROOT,DIPART,DINDEX,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; CHKONE--return the list of partial matches to DIVALUE in DINDEX
 ; proc, DIVALUE, DICOUNT, DISCREEN, DIDENT by reference
 N DIOUT S DIOUT=0
 N DIVALUE S DIVALUE=DIPART
 N DIMORE S DIMORE=+DIPART=DIPART I DIMORE D MORE I DIOUT Q
 F  D  Q:DIOUT
 . S DIVALUE=$O(@DIROOT@(DINDEX,DIVALUE))
 . D  I DIOUT Q:'DIMORE  D MORE D  Q:DIOUT
 . . I DIPART'=$E(DIVALUE,1,$L(DIPART)) S DIOUT=1 Q
 . D EXACT(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . I DIFLAGS["q" S DIOUT=1 Q
 Q
 
MORE 
 ; PARTIAL--continue numeric partial down into string numerics
 S DIMORE=0,DIOUT=0
 S DIVALUE=DIPART_" "
 S DIVALUE=$O(@DIROOT@(DINDEX,DIVALUE),-1)
 S DIOUT=$E($O(@DIROOT@(DINDEX,DIVALUE)),1,$L(DIPART))'=DIPART
 Q
 
EXACT(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; CHKONE/PARTIAL--consider selecting value DIVALUE
 ; proc, DIEN, DIVALUE, DICOUNT, DISCREEN, DIDENT by reference
 N DIENTRY S DIENTRY="" F  D  I DIENTRY="" Q
 . S DIENTRY=$O(@DIROOT@(DINDEX,DIVALUE,DIENTRY)) Q:DIENTRY=""
 . S DIEN=DIENTRY_DIEN
 . D ENTRY(DIFILE,DIEN,.DIFLAGS,.DIROOT,.DIVALUE,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . S $P(DIEN,",")=""
 . I DIFLAGS["q" S DIENTRY="" Q
 Q
 
ENTRY(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; SPECIAL/EXACT--consider selecting entry # DIENTRY
 ; proc, DIEN, DIVALUE, DICOUNT, DISCREEN, DIDENT by reference
 N DIENTRY S DIENTRY=$P(DIEN,",")
 N DINODE S DINODE=$G(@DIROOT@(DIENTRY,0))
 I '$$VMINUS9^DIEFU(DIFILE,DIEN) Q
 N DIKEY S DIKEY=$P(DINODE,"^") Q:DIKEY=""
 N DIFIELD,DIOUT S DIOUT=0
SCREEN 
 N DISCR F DISCR="DISCREEN","DISCREEN(""F"")" I @DISCR'="" D  Q:DIOUT
 . I $D(DINDEX(0,"GET")),'$D(DIFIELD) S @("DIFIELD="_DINDEX(0,"GET"))
 . N %
 . N D S D=DINDEX
 . N DIC S DIC=DIROOT("O")
 . S DIC(0)=$TR(DIFLAGS,"fglpqtuv")
 . N X S X=DIVALUE
 . N Y M Y=DIEN S Y=DIENTRY
 . N Y1 S Y1=$G(@DIROOT@(DIENTRY,0)),Y1=DIEN
 . I 1 X @DISCR ;***** NAKED *****
 . E  S DIOUT=1
 . I $G(DIERR) D
 . . S DIOUT=1,DIFLAGS=DIFLAGS_"q"
 . . N DICONTXT
 . . S DICONTXT=$S(DISCR["F":"Whole File Screen",1:"Screen Parameter")
 . . D ERR^DICF6(120,DIFILE,DIEN,"",DICONTXT)
 Q:DIOUT
ACCEPT 
 I $D(@DILIST@("B",DIKEY,DIENTRY)) Q
 I 'DICOUNT("LOOK") D  Q:DIFLAGS["q"
 . S DICOUNT=DICOUNT+1
 . I DIFLAGS'["f" D 
ANCHOR . .
 . . N DINODE S DINODE(0)=""
 . . I DIFLAGS'["S" D
 . . . I DIFLAGS'["P" S @DILIST@(1,DICOUNT)=DIKEY
 . . . E  S DINODE(0)=DIKEY
 . . I DINDEX'="#" D
 . . . I DIFLAGS'["P" S @DILIST@(2,DICOUNT)=DIENTRY
 . . . E  S DINODE(0)=DINODE(0)_$E(U,DIFLAGS'["S")_DIENTRY
IDS . .
 . . D IDS^DICU2(DIFILE,.DIEN,.DIFLAGS,DIVALUE,.DIROOT,.DINDEX,.DICOUNT,.DIDENT,.DILIST,.DINODE)
 . . I $G(DIERR) S DIOUT=1,DIFLAGS=DIFLAGS_"q"
 . . I DIFLAGS["P" M @DILIST@(DICOUNT)=DINODE
FORCED .
 . E  D
 . . I DIFLAGS'["v" S @DILIST@(DICOUNT)=DIENTRY
 . . E  S @DILIST@(DICOUNT)=DIENTRY_DIROOT("V")
 . S @DILIST@("B",DIKEY,DIENTRY)=""
LOOKING 
 E  S DICOUNT("MORE")=1
 I DICOUNT("MAX")="" Q
 I DICOUNT=DICOUNT("MAX") S DICOUNT("LOOK")=1
 I DICOUNT("MORE") S DIFLAGS=DIFLAGS_"q",DIOUT=1
 Q

DICF4
DICF4 ;SEA/TOAD-VA FileMan: Finder, Part 4 (No Index) ;10/14/94  12:29 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
UPRIGHT(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; FIND--manual selection engine, check upright file for matches
 ; proc, DIFILE & DIROOT by value
 N DINDEX,DIFNODE,DIFPIECE,DIOUT
 I DIFLAGS["O" S DIFLAGS=DIFLAGS_"X"
 S DIDA=0,DIOUT=0
 D PREP(DIFILE,.DIFLAGS,.DIVALUE,.DINDEX,.DISCREEN,.DIOUT)
 I DIOUT Q
41 F  D  I DIOUT D DECIDE^DICF2(.DIFLAGS,.DINDEX,DICOUNT,.DIOUT) Q:DIOUT  S DIDA=0
 . S DIDA=$O(@DIROOT@(DIDA))
 . I 'DIDA S DIOUT=1 Q
 . S $P(DIEN,",")=DIDA
 . D CHECK(DIFILE,.DIEN,.DIFLAGS,.DIVALUE,.DIROOT,.DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
 . S $P(DIEN,",")=""
 . I DIFLAGS["q" S DIOUT=1 Q
 Q
 
PREP(DIFILE,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIOUT) 
 ; UPRIGHT--lookup .01 type, add transform values to DIVALUE
 ; proc, DIFILE & DIFLAGS by value
 N DIFFLAG
 S DINDEX(0,"COUNT")=0
 S DINDEX(0,"DEF")=$G(^DD(DIFILE,.01,0))
51 I DINDEX(0,"DEF")="" S DIOUT=1 Q
 S DIFFLAG=$P(DINDEX(0,"DEF"),U,2)
 I DIFFLAG["P"!(DIFFLAG["V") S DIFLAGS=DIFLAGS_"p"
 S DINDEX(0,"TRANSFORM")=DIFFLAG'["F"&(DIFFLAG'["N")
 I 'DINDEX(0,"TRANSFORM") Q
 S DINDEX(0,"FIRST")=10
 S DINDEX(0,"LAST")=9
52 I DIFFLAG["D" D PREPD^DICF2(.DIVALUE,.DINDEX,.DISCREEN) Q
 I DIFFLAG["S" D PREPS^DICF6(DIFLAGS,.DIVALUE,.DINDEX,.DISCREEN) Q
 Q
 
CHECK(DIFILE,DIEN,DIFLAGS,DIVALUE,DIROOT,DINDEX,DICOUNT,DISCREEN,DIDENT,DILIST) 
 ; UPRIGHT--check one record for possible matches
 ; proc, DIFILE, DIFLAGS, & DIROOT by value
 N DIKEY,DITRY,DIXFORM
 S DIKEY=$P($G(@DIROOT@(+DIEN,0)),U)
 I DIKEY="" Q
 S DIXFORM=0
 F  D  I DIXFORM="" Q
 . S DIXFORM=$O(@DILIST("LVA")@("V")) I DIXFORM="" Q
 . S DIVALUE=@DILIST("LVA")@("V")
 . S DISCREEN=@DILIST("LVA")@("S")
 . S DITRY=1
 . I DIVALUE?.NP,+DIVALUE=DIVALUE S DITRY=DIFLAGS'["p"
 . I DITRY,$P(DIKEY,DIVALUE)="" D
 . . S DINDEX="#"
 . . D ENTRY^DICF3(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,DINDEX,.DICOUNT,.DISCREEN)
 . . I DIFLAGS["q" S DIXFORM="" Q
 Q
 
SOUNDEX(DIVALUE) 
 ; func, convert value to soundex value
 N DICODE S DICODE="01230129022455012623019202"
 N DISOUND S DISOUND=$C($A(DIVALUE)-(DIVALUE?1L.E*32))
 N DIPREV S DIPREV=$E(DICODE,$A(DIVALUE)-64)
 N DICHAR,DIPOS
 F DIPOS=2:1 S DICHAR=$E(DIVALUE,DIPOS) Q:","[DICHAR  D  Q:$L(DISOUND)=4
 . Q:DICHAR'?1A
 . N DITRANS S DITRANS=$E(DICODE,$A(DICHAR)-$S(DICHAR?1U:64,1:96))
 . Q:DITRANS=DIPREV  Q:DITRANS=9
 . S DIPREV=DITRANS
 . I DITRANS'=0 S DISOUND=DISOUND_DITRANS
 Q $E(DISOUND_"000",1,4)
 
ISSNDX(DIFILE,DIFIELD,DINDEX) 
 ; func, return whether DINDEX is a soundex index
 N DIDEF,DIEN,DINAME S DIDEF="",DIEN=0
 F  S DIEN=$O(^DD(DIFILE,DIFIELD,1,DIEN)) Q:'DIEN  D  Q:DINDEX=DINAME
 . S DIDEF=$G(^DD(DIFILE,DIFIELD,1,DIEN,0))
 . S DINAME=$P(DIDEF,U,2)
 Q $P(DIDEF,U,3)="SOUNDEX"

DICF5
DICF5 ;SEA/TOAD-VA FileMan: Finder, Part 5 (Ptr Indexes) ;9/6/96  14:06
 ;;21.0;VA FileMan;**17,27**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12164;3301437;2617;
 
PREPP(DIFILE,DIFLAGS,DINDEX,DITYPE,DISKIP,DILIST) 
 ; PREPIX^DICF2--transform value for indexed pointer field
 ; proc, DINDEX passed by ref
 N DIF,DINODE,DIPFILE,DIPLIST,DIPVAL,DISAVE
 S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"Xg"))
 S DIPVAL=@DILIST("LVA")@("V")
 S DILIST("SAVE")=DILIST("LVA")
 S DILIST("LVA")="^TMP(""DILVA"",$J,"_DILIST(0)_")"
 S DIPLIST=$NA(@DILIST("LVA")@("V"))
90 S DIPLIST(0)=DILIST(0)+1
 S DIPLIST("LVA")=DILIST("SAVE")
 S DISAVE=@DILIST("SAVE")@("S")
 I DISAVE'="" S @DILIST("SAVE")@("S")=""
 F DINODE="1","2","0,5","0,6" D
 . S @("DISAVE("_DINODE_")=$G(@DILIST(""SAVE"")@(""S"","_DINODE_"))")
 . I @("DISAVE("_DINODE_")'=""""") D
 . . S @("@DILIST(""SAVE"")@(""S"","_DINODE_")=""""")
91 N DIXFILE S DIXFILE=DINDEX(0,"FILE")
 N DIXFIELD S DIXFIELD=DINDEX(0,"FIELD")
 I DITYPE="P" D
 . N DIPFILE M DIPFILE("CHAIN")=DIFILE("CHAIN")
 . S DIPFILE=+$P($P(DINDEX(0,"DEF"),U,2),"P",2)
 . D FIND^DICF(.DIPFILE,"","","Mp"_DIF,"","","","","",.DIPLIST,DIPLIST)
 . S DISKIP=DIPLIST("C")=0
 I DISKIP Q
92 I DITYPE="VP" D
 . S DIPLIST("C")=0
 . N DIVFILE,DIOUT S DIVFILE=0,DIOUT=0 F  D  Q:DIOUT
 . . S DIVFILE=$O(^DD(DIXFILE,DIXFIELD,"V","B",DIVFILE))
 . . I DIVFILE="" S DIOUT=1 Q
 . . N DIPFILE M DIPFILE("CHAIN")=DIFILE("CHAIN")
 . . S DIPFILE=DIVFILE
 . . D FIND^DICF(.DIPFILE,"","","Mpv"_DIF,"","","","","",.DIPLIST,DIPLIST)
 . . S DISKIP=DIPLIST("C")=0&DISKIP
93 . I DIPVAL["." D
 . . D PIECES(.DIFILE,DIXFILE,DIXFIELD,DIF,DIPVAL,.DISKIP,.DIPLIST)
 I DISAVE'="" S @DILIST("SAVE")@("S")=DISAVE
 I 'DISKIP S @DILIST("LVA")@("S")=@DILIST("SAVE")@("S")
 F DINODE="1","2","0,5","0,6" D
 . I @("DISAVE("_DINODE_")'=""""") D
 . . S @("@DILIST(""SAVE"")@(""S"","_DINODE_")=DISAVE("_DINODE_")")
 Q
 
PIECES(DIFILE,DIXFILE,DIXFIELD,DIFLAGS,DIPVAL,DISKIP,DIPLIST) 
 ; proc, add file.value lookups to index's LVA
 N DILOWER S DILOWER="abcdefghijklmnopqrstuvwxyz"
 N DIUPPER S DIUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 N DIFILEN S DIFILEN=$TR($P(DIPVAL,"."),DILOWER,DIUPPER)
 N DIFILES D VPFILES^DIEV1(DIXFILE,DIXFIELD,DIFILEN,.DIFILES)
 K DIPLIST("LVA")
 N DIVALN S DIVALN=$P(DIPVAL,".",2,9999)
 N DIVFILE S DIVFILE=""
 F  S DIVFILE=$O(DIFILES(DIVFILE)) Q:DIVFILE=""  D
 . N DIPFILE M DIPFILE("CHAIN")=DIFILE("CHAIN")
 . S DIPFILE=DIVFILE
 . D FIND^DICF(.DIPFILE,"","","Mlpv"_DIFLAGS,DIVALN,"","","","",.DIPLIST,DIPLIST)
 S DISKIP=DIPLIST("C")=0&DISKIP
 Q

DICF6
DICF6 ;SEA/TOAD-VA FileMan: Finder, Part 7 (Sets of Codes) ;10/18/94  12:02 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
PREPS(DIFLAGS,DINDEX,DILIST) 
 ; transform value for indexed set of codes field
 ; proc, DINDEX passed by ref
 N DICODE,DIMEAN,DIPAIR,DISKIP,DITRY,DIVAL
 N DISET S DISET=$P(DINDEX(0,"DEF"),U,3)
CODES 
 N DIP F DIP=1:1:$L(DISET,";")-1 D
 . S DIPAIR=$P(DISET,";",DIP)
 . S DIVAL=0 F  D  Q:DIVAL=""!(DIVAL>8)
 . . S DIVAL=$O(@DILIST("LVA")@("V",DIVAL)) Q:DIVAL=""!(DIVAL>8)
 . . I "^1^2^5^6^"'[(U_DIVAL_U) Q
 . . S DIMEAN=$P(DIPAIR,":",2)
 . . S DITRY=@DILIST("LVA")@("V",DIVAL)
 . . I $P(DIMEAN,DITRY)'="" Q
 . . I DIFLAGS["X",DIMEAN'=DITRY Q
 . . S DICODE=$P(DIPAIR,":")
 . . I DICODE=DITRY Q
MATCH . . 
 . . D ADDVAL^DICF2(DICODE,.DINDEX,.DILIST)
 Q
 
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) 
 ; error logging procedure
 N DIPE
 N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 Q
 
 

DICL
DICL ;SEA/TOAD-VA FileMan: Lookup: Lister ;5/8/96  15:23
 ;;21.0;VA FileMan;**17,8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12019;4619639;3643;
 
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DICALSCR,DIWRITE,DILIST,DIMSGA) 
 ; ENTRY POINT--return a list of entries from a file
 ; proc, DIFROM may be passed by ref
 
IN ; Branch point from LIST^DIC
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
 
INPUT 
 N DIERN,DIPE
 S DIFLAGS=$G(DIFLAGS)
 S DIFIELDS=$G(DIFIELDS)
 S DINUMBER=$G(DINUMBER) I DINUMBER="" S DINUMBER="*"
 S DIPART=$G(DIPART)
 S DIFROM=$G(DIFROM)
 S DIFROM("IEN")=$G(DIFROM("IEN"))
 S DINDEX("WAY")=1 I DIFLAGS["B" S DINDEX("WAY")=-1
 S DINDEX=$G(DINDEX,"B"),DINDEX=$S(DINDEX?1U.UNP:DINDEX,1:"B")
 S DICALSCR=$G(DICALSCR)
 S DIWRITE=$G(DIWRITE)
 
OUTPUT 
 I DIFLAGS'["f" D  Q:$G(DIERR)
 . I $G(DILIST)'="" D  Q:$G(DIERR)
 . . I DILIST'?.1"^"1U.7UN.ANP,DILIST'?.1"^%".7UN.ANP D  Q
 . . . D BLD^DIALOG(202,"target array")
 . . S DILIST=$NA(@DILIST@("DILIST"))
 . . Q
 . E  S DILIST="^TMP(""DILIST"",$J)"
 . K @DILIST
 . Q
 
FILE 
 N DIFILSCR,DINODE,DIROOT,DISCREEN
 S DIFILE=+$G(DIFILE) I 'DIFILE S DIERN=202,DIPE(1)="file" D ERROUT Q
 S DINODE=$G(^DD(DIFILE,.01,0))
 I DINODE="" D  Q
 . S DIERN=$S('$D(^DD(DIFILE)):401,1:406),DIPE("FILE")=DIFILE D ERROUT Q
 I $P(DINODE,U,2)["W" S DIERN=407,DIPE("FILE")=DIFILE D ERROUT Q
 S DIFIEN=$G(DIFIEN) I DIFIEN="" S DIFIEN=","
 I '$$IEN^DIDU1(DIFIEN) D  Q
 . I '$$IEN^DIDU1(DIFIEN_",") S DIERN=202,DIPE(1)="IENS" D ERROUT Q
F1 . E  S DIERN=304,DIPE("IENS")=DIFIEN D ERROUT Q
 I $P(DIFIEN,",")'="" S DIERN=306,DIPE("IENS")=DIFIEN D ERROUT Q
 S DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,1,1) I $G(DIERR) D OUT Q
 I DIROOT'?1"^"1U.7UN.ANP,DIROOT'?1"^%".7UN.ANP D  Q
 . S DIERN=402
 . S DIPE("FILE")=DIFILE
 . S DIPE("IEN")=DIFIEN
 . S DIPE("ROOT")=DIROOT
 . D ERROUT
 . Q
 S DIROOT("O")=$$OREF^DIQGU(DIROOT)
 I DIFLAGS["U" S DIFILSCR=""
 E  I $P($G(@DIROOT@(0)),U,2)'["s" S DIFILSCR=""
 E  S DIFILSCR=$G(^DD(DIFILE,0,"SCR"))
 S DISCREEN=DIFILSCR'=""!(DICALSCR'="")
 
CHECKS 
 N DIFROML,DILAST,DIOUT,DIPARTL,DIUSEFRM
 I $TR(DIFLAGS,"BIMPQSUf")'="" S DIERN=301,DIPE(1)=DIFLAGS D ERROUT Q
 S DIPARTL=$L(DIPART)
 S DIUSEFRM=DIFROM("IEN")'=""
 I DINUMBER'="*",DINUMBER<1!(DINUMBER\1'=DINUMBER) D  Q
 . S DIERN=202,DIPE(1)="Number" D ERROUT
 S DIOUT=0
 I DIPART'="",$E(DIFROM,1,DIPARTL)'=DIPART D
 . S DIOUT=0
 . I DINDEX("WAY")=1 D  Q
 . . I DIFROM]](DIPART_$S(+DIPART=DIPART:" ",1:"")) S DIOUT=1 Q
 . . S DIFROM=DIPART_$S(+DIPART'=DIPART:"",DIFROM']]DIPART:"",1:" ")
 . . S DIUSEFRM=1
 . . Q
C1 . ; I DINDEX("WAY")=-1
 . I DIFROM'="",DIPART]]DIFROM S DIOUT=1 Q
 . I +DIPART'=DIPART D  Q
 . . S DIFROM=DIPART
 . . S DIFROML=$L(DIFROM)
 . . S DILAST=$E(DIFROM,DIFROML)
 . . S DILAST=$C($A(DILAST)+1)
 . . S $E(DIFROM,DIFROML)=DILAST
 . . Q
 . S DIFROM=$S(DIFROM="":" ",DIFROM]](DIPART_" "):" ",1:"")
 . S DIFROM=DIPART+$S($E(DIPART)="-":-1,1:1)_DIFROM
 . Q
 I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" Q
 
IXANDID 
 N DIDENT
 D BOTH^DICU1(.DIFILE,DIFLAGS,DIROOT,.DINDEX,DIFIELDS,DIWRITE,.DIDENT)
 I $G(DIERR) D OUT K:$G(DIFILE("NO B")) @DIROOT@("B") Q
 
BRANCH 
 ; I $G(ZRT) S ZRT(ZRT)="BRANCH^"_$ZH,ZRT=ZRT+1
 G PREP^DICL1
 
ERR D BLD^DIALOG(DIERN,.DIPE,.DIPE) S DIFROM="",DIFROM("IEN")="" Q
 
ERROUT D ERR,OUT Q
 
OUT I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 D CALLOUT^DIEFU($G(DIMSGA)):$G(DIMSGA)'=""
 Q

DICL1
DICL1 ;SEA/TOAD-VA FileMan: Lookup: Lister, Part 2 ;6/13/95  15:12 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11814;2778676;
 
PREP 
 N DIEN,DIENTRY,DIOUT1,DIOUT2,DISUB1
 S DIOUT1=0
 S DIENTRY=DIFROM
 D DA^DILF(DIFIEN,.DIEN)
 I DINDEX("WAY")=1 S DILIST("ORDER")=0
 E  S DILIST("ORDER")=DINUMBER+1
 
REVERSE 
 N DIREVERS,DITO,DITOIN
 I DINUMBER="*",DINDEX("WAY")=-1 D
 . S DIREVERS=1
 . S DITO=DIFROM
 . S DITOIN=DIFROM("IEN")
 . S DINDEX("WAY")=1
 . S DIFROM=DIPART
 . I DIFROM'="" S DIUSEFRM=1
 . S DIFROM("IEN")=""
R1 . S DIENTRY=DIPART
 . S DILIST("ORDER")=0
 . Q
 E  D
 . S DIREVERS=0
 . S DITO=""
 . S DITOIN=""
 . Q
 
PREP2 ; prepare to list entries
 N DICODE,DID,DIDT,DIDVAL
 N DIMSG,DIOUT3,DISKIP,DIVAL,X,Y
 N DICOUNT D
 . S DICOUNT=0
 . S DICOUNT("MAX")=DINUMBER
 . S DICOUNT("JUST LOOKING")=0
 . S DICOUNT("LAST ENTRY")=""
 . S DICOUNT("LAST IEN")=""
 S DIENTRY("PREVIOUS")="",DIENTRY("PREVIOUS EXTERNAL")=""
P1 I +DIPART'=DIPART S DICOUNT("MORE?")=0
 E  D
 . I DINDEX("WAY")=1,+DIFROM=DIFROM S DICOUNT("MORE?")=1 Q
 . I DINDEX("WAY")=-1,+DIFROM'=DIFROM S DICOUNT("MORE?")=1 Q
 . S DICOUNT("MORE?")=0 Q
 I DINDEX("TYPE")="P",DIFLAGS'["I",DIFLAGS'["Q" D
 . S DIFLAGS=DIFLAGS_"p"
 . D POINT(.DIFILE,.DIROOT,.DINDEX,.DIFROM)
 
LONG 
 D
 . N DILENGTH S DILENGTH=+$P(DINDEX("NODE"),">",2)
 . I 'DILENGTH S DILENGTH=99999
 . S DIFROM=$E(DIFROM,1,DILENGTH)
 . S DIPART=$E(DIPART,1,DILENGTH)
 . S DITO=$E(DITO,1,DILENGTH)
 
GETLIST 
 ; I $G(ZRT) S ZRT(ZRT)="BRANCH^"_$ZH,ZRT=ZRT+1
 D LIST^DICL2
 
KTMPIX 
 I $G(DIFILE("NO B")) D
 . I DIFLAGS'["p" K @DIROOT@("B") Q
 . N DILVL,DIROOT F DILVL=1:1:DIFILE("STACK") D
 . . I '$G(DIFILE("STACK",DILVL,"NO B")) Q
 . . S DIROOT=U_$P(DIFILE("STACK",DILVL),U,2)
 . . K @DIROOT@("B")
FINAL 
 I $G(DIERR) K @DILIST D OUT^DICL Q
 I DICOUNT=0,$O(@DIROOT@(DINDEX,""))="",$O(@DIROOT@(0)) D  Q
 . S DIERN=420,DIPE(1)=DINDEX,DIPE("FILE")=DIFILE D ERROUT^DICL
 S @DILIST@(0)=DICOUNT_U_DICOUNT("MAX")_U_DICOUNT("MORE?")
 K DIFROM("LOOKING FOR START")
 I DICOUNT("MORE?") D
 . S DIFROM=DIENTRY
 . S DIFROM("IEN")=$S(DIFLAGS'["p":DIEN,1:$G(DICOUNT("LAST IEN")))
 E  S DIFROM="",DIFROM("IEN")=""
 Q
 
POINT(DIFILE,DIROOT,DINDEX,DIFROM) ;
 ; prepare to list a pointer index
 S DIFILE("MAIN")=DIFILE
 S DIROOT("MAIN")=DIROOT
 S DIROOT("MAIN O")=DIROOT("O")
 D FOLLOW^DICL3(.DIFILE,.DIROOT,DINDEX("PTR"),DINDEX("NODE"))
 N TEMP M TEMP=DINDEX K DINDEX M DINDEX("MAIN")=TEMP
 S DINDEX="B",DINDEX("WAY")=DINDEX("MAIN","WAY")
 D INDEX^DICU1(.DIFILE,.DINDEX,DIROOT,1)
 S DIFROM("LOOKING FOR START")=DIFROM'=""&(DIFROM("IEN")'="")
 Q
 
 

DICL2
DICL2 ;SEA/TOAD-VA FileMan: Lookup: Lister, Part 3 ;10/24/95  14:42
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11926;6316876;
 
LIST 
 F  D  Q:DIOUT1!$G(DIERR)
 . ; I $G(ZRT) S ZRT(ZRT)="LOOP "_(ZRT-2)_"^"_$ZH,ZRT=ZRT+1
 . I 'DIUSEFRM S DIENTRY=$O(@DIROOT@(DINDEX,DIENTRY),DINDEX("WAY"))
 . S DIUSEFRM=0
 . D  I DIOUT1 Q:'DICOUNT("MORE?")  D MORE D  Q:DIOUT1
 . . I DIENTRY="" S DIOUT1=1 Q
 . . I $E(DIENTRY,1,DIPARTL)'=DIPART S DIENTRY="",DIOUT1=1 Q
 . . I DITO'="",DITOIN="",DITO']]DIENTRY S DIENTRY="",DIOUT1=1 Q
 . I DIFLAGS'["p" S DIEN=DIFROM("IEN"),DIFROM("IEN")=""
 . S DIOUT2=0
RECORDS .
 . F  D  Q:DIOUT2!$G(DIERR)
 . . S DIEN=$O(@DIROOT@(DINDEX,DIENTRY,DIEN),DINDEX("WAY"))
 . . I DIEN="" S DIOUT2=1 Q
 . . S DIEN(0)="" I DINDEX="B" S DIEN(0)=$G(^(DIEN)) ; ***** NAKED *****
 . . I DIFLAGS["M",DIEN(0) Q
 . . I DIFLAGS'["p",DITOIN'="",DITO=DIENTRY,DIEN'<DITOIN D  Q
 . . . S DIEN="",DIENTRY="",DIOUT1=1,DIOUT2=1 Q
 . . I DIFLAGS["p" D
 . . . D BACKTRAK^DICL3(.DIFILE,DIEN,DIFILE("STACK"))
 . . E  D CONSIDER
MAX . 
 . Q:$G(DIERR)
 . I DICOUNT=DICOUNT("MAX"),'DICOUNT("JUST LOOKING") S DIOUT1=1
 Q
 
MORE ; ENTRIES--for numeric partials, continue down into string subscripts
 ; . . .that start with the numeric value
 S DIOUT1=0,DICOUNT("MORE?")=0
 I DINDEX("WAY")=1 S DIENTRY=$O(@DIROOT@(DINDEX,DIPART_" "),-1)
 E  S DIENTRY=DIPART+$S($E(DIPART)="-":-1,1:1)
 S DIENTRY=$O(@DIROOT@(DINDEX,DIENTRY),DINDEX("WAY"))
 Q
 
SCREEN(DIFILE,DIEN,DIFLAGS,DIROOT,DIFIEN,DISCREEN,DICALSCR,DIFILSCR,DINDEX) 
 I '$$VMINUS9^DIEFU(DIFILE,","_DIEN_DIFIEN) Q 1
 I $P($G(@DIROOT@(DIEN,0)),U)="" Q 1
 
S1 N DISKIP S DISKIP=0
 N DISCR
 I DISCREEN F DISCR="DIFILSCR","DICALSCR" I @DISCR'="" D  Q:DISKIP
 . N %,D S D=DINDEX
 . N DIC S DIC=DIROOT("O"),DIC(0)=$TR(DIFLAGS,"fpq")
 . N Y M Y=DIEN
 . N Y1 S Y1=DIEN_DIFIEN
 . N X S X=$G(@DIROOT@(DIEN,0)),X=""
 . I 1 X @DISCR S DISKIP='$T
 . I $G(DIERR) D
 . . S DIFLAGS=DIFLAGS_"q",DISKIP=1
 . . N DICONTXT
 . . S DICONTXT=$S(DISCR["F":"Whole File Screen",1:"Screen Parameter")
 . . D ERR^DICF6(120,DIFILE,DIEN,"",DICONTXT)
 Q DISKIP
 
ACCEPT(DIFILE,DIEN,DIFLAGS,DIROOT,DIFIEN,DIENTRY,DICOUNT,DINDEX,DIDENT,DILIST) 
 I DICOUNT("JUST LOOKING") D  Q
 . S DIENTRY=DICOUNT("LAST ENTRY")
 . S DIEN=DICOUNT("LAST IEN")
 . S DICOUNT("JUST LOOKING")=0
 . S DICOUNT("MORE?")=1
 . S DIOUT2=1
 
A1 S DICOUNT=DICOUNT+1
 I DICOUNT=DICOUNT("MAX") D
 . S DICOUNT("LAST ENTRY")=DIENTRY
 . S DICOUNT("LAST IEN")=DIEN
 . S DICOUNT("JUST LOOKING")=1
 
A2 S DILIST("ORDER")=DILIST("ORDER")+DINDEX("WAY")
 
A3 I $G(DIEN(0)) S DIVAL=DIENTRY
 E  I DIFLAGS'["p" D  Q:$G(DIERR)
 . I DIFILE("INDEX")'=DIFILE N DIENS D  Q:$G(DIERR)
 . . S DIEN("SAVE")=DIEN
 . . S DIEN=$$IENS(DIROOT,DINDEX,DIENTRY,DIEN)
 . . S DIROOT("SAVE")=DIROOT
 . . S DIROOT=$$ROOT^DIQGU(DIFILE("INDEX"),DIEN,1,1) Q:$G(DIERR)
 . S @("DIVAL="_DINDEX("GET"))
 . I DIFLAGS'["I" S DIVAL=$$FORMAT^DICU2(DIFILE("INDEX"),DINDEX("FIELD"),"K",DIVAL,DINDEX("TYPE"),DINDEX("CODE"),.DIENTRY)
 . I DIFILE("INDEX")'=DIFILE S DIROOT=DIROOT("SAVE"),DIEN=DIEN("SAVE")
 E  S DIVAL=DIENTRY I DIFLAGS'["I" D
 . S DIVAL=$$EXTERNAL^DIDU(DIFILE("INDEX"),DINDEX("FIELD"),"",DIENTRY)
 
A4 N DINODE S DINODE(0)=""
 I DIFLAGS'["S" D
 . I DIFLAGS'["P" S @DILIST@(1,DILIST("ORDER"))=DIVAL
 . E  S DINODE(0)=DIVAL
 I DINDEX'="#" D
 . I DIFLAGS'["P" S @DILIST@(2,DILIST("ORDER"))=DIEN
 . E  S DINODE(0)=DINODE(0)_$E(U,DIFLAGS'["S")_DIEN
 I DIFLAGS["f" Q
 
A5 S DIEN=DIEN_DIFIEN
 D IDS^DICU2(DIFILE,.DIEN,DIFLAGS_(DIFLAGS["I"),"",.DIROOT,.DINDEX,DILIST("ORDER"),.DIDENT,DILIST,.DINODE)
 I DIFLAGS["P" M @DILIST@(DILIST("ORDER"))=DINODE
 S DIEN=+DIEN
 Q
 
CONSIDER 
 ; consider an entry. if not screened, add to list
 Q:$$SCREEN(DIFILE,.DIEN,DIFLAGS,.DIROOT,DIFIEN,DISCREEN,DICALSCR,DIFILSCR,DINDEX)
 D ACCEPT(.DIFILE,.DIEN,DIFLAGS,.DIROOT,DIFIEN,.DIENTRY,.DICOUNT,.DINDEX,.DIDENT,.DILIST)
 Q
 
IENS(DIROOT,DINDEX,DIENTRY,DIEN) 
 ; return the IENS for a whole file index entry
 N DIENS,DIENSUB
 S DIENS=DIEN_",",DIENSUB=""
 S DIROOT=$NA(@DIROOT@(DINDEX,DIENTRY,DIEN))
 F  D  Q:DIENSUB=""
 . S DIENSUB=$O(@DIROOT@(DIENSUB)) Q:DIENSUB=""
 . S DIENS=DIENSUB_","_DIENS
 . S DIROOT=$NA(@DIROOT@(DIENSUB))
 Q DIENS
 

DICL3
DICL3 ;SEA/TOAD-VA FileMan: Lookup: Lister, Part 4 ;6/20/95  17:36 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11819;4321703;
 
POINT 
 ; BRANCH^DICL--perform recursive list for pointer index
 N DICODE,DIFIENP,DILVL,DIPLVL,DISCREEN
 S DIPLVL=+$G(DIFILE("LVL"))
 N DIFILE
 S DIFILE=+$P($P(DINDEX("NODE"),U,2),"P",2)
 S DILVL=DIPLVL+1
 S DIFILE("LVL")=DILVL
 S DISCREEN="X "_$NA(^TMP("DILVL",$J,DILVL))
 S DICODE="N DIPLVL,DIROOT S DIPLVL="_DIPLVL_",DIROOT=$NA("_$NA(@DIROOT@(DINDEX))_"),DIFIENP=$O(@DIROOT@(Y,"""")) I DIFIENP'="""""
 I DIPLVL S DICODE=DICODE_" X "_$NA(^TMP("DILVL",$J,DIPLVL))
 S ^TMP("DILVL",$J,DILVL)=DICODE
RECUR 
 ; perform recursive call
 D LIST^DICL(.DIFILE,"","",DIFLAGS_"f",DINUMBER,DIFROM,DIPART,"B",DICALSCR,"",DILIST)
 K ^TMP("DILVL",$J,DILVL)
 I $D(DIERR) D CALLOUT^DIEFU($G(DIMSGA)):$G(DIMSGA)'="" Q
 Q
 
FOLLOW(DIFILE,DIROOT,DIPOINT,DIDEF) 
 ; follow pointer to end, building stack along the way
 N DILVL S DILVL=0
 I $G(DIFILE("NO B")) S DIFILE("STACK",1,"NO B")=1
 F  D  Q:DIPOINT=""
 . S DILVL=DILVL+1
 . S DIFILE("STACK",DILVL)=DIFILE_DIROOT_U_DIFILE("INDEX")
 . I DILVL>1,'$D(^DD(DIFILE,0,"IX","B")),'$D(@DIROOT@("B")) D
 . . S DIFILE("STACK",DILVL,"NO B")=1
 . . D TMPIX^DICU2(DIROOT)
 . I 'DIPOINT S DIPOINT="" Q
 . S (DIFILE,DIFILE("INDEX"))=DIPOINT
 . S DIROOT=$$CREF^DIQGU(U_$P(DIDEF,U,3))
 . S DIDEF=$G(^DD(DIFILE,.01,0))
 . S DIPOINT=+$P($P(DIDEF,U,2),"P",2)
 S DIFILE("STACK")=DILVL
 Q
 
BACKTRAK(DIFILE,DIEN,DILVL) 
 ; follow pointer chain to root, considering all pointing records
 ; formal parameter list includes only those needed for recursion
 ; for rest of list, see $$SCREEN and ACCEPT calls within loop
 S DILVL=DILVL-1
 S DIFILE=$P(DIFILE("STACK",DILVL),U)
 N DIROOT1 S DIROOT1=U_$P(DIFILE("STACK",DILVL),U,2)
 S DIFILE("INDEX")=$P(DIFILE("STACK",DILVL),U,3)
 N DIVALUE S DIVALUE=DIEN
B1 S DIEN="" F  D  Q:DIEN=""!(DIFLAGS["q")
 . N DINDEX1 S DINDEX1=$S(DILVL>1:"B",1:DINDEX("MAIN"))
 . S DIEN=$O(@DIROOT1@(DINDEX1,DIVALUE,DIEN),DINDEX("WAY"))
 . Q:DIEN=""
 . I DILVL>1 D
 . . D BACKTRAK(.DIFILE,DIEN,DILVL) Q:DIFLAGS["q"
 . E  D
 . . I DITOIN'="",DITO=DIENTRY,DIEN=DITOIN D  Q
 . . . S DIFLAGS=DIFLAGS_"q",DIEN="",DIENTRY="",DIOUT1=1,DIOUT2=1 Q
 . . I DIFROM("LOOKING FOR START") N DISKIP S DISKIP=0 D  Q:DISKIP
 . . . I DIFROM=DIENTRY,DIFROM("IEN")'=DIEN S DISKIP=1 Q
 . . . S DIFROM("LOOKING FOR START")=0 Q:DIFROM'=DIENTRY  S DISKIP=1
B2 . . N DIROOT2
 . . S DIROOT2=DIROOT("MAIN")
 . . S DIROOT2("O")=DIROOT("MAIN O")
 . . N DINDEX2 D
 . . . M DINDEX2=DINDEX("MAIN")
 . . . M DINDEX2("END")=DINDEX
 . . . K DINDEX2("END","MAIN"),DINDEX2("MAIN")
 . . Q:$$SCREEN^DICL2(DIFILE,.DIEN,DIFLAGS,.DIROOT2,DIFIEN,DISCREEN,DICALSCR,DIFILSCR,DINDEX2)
 . . I 'DICOUNT("JUST LOOKING") S DICOUNT("LAST IEN")=DIEN
 . . D ACCEPT^DICL2(.DIFILE,.DIEN,DIFLAGS,.DIROOT2,DIFIEN,DIVALUE,.DICOUNT,.DINDEX2,.DIDENT,.DILIST)
 . . I DIOUT2 S DIFLAGS=DIFLAGS_"q"
B3 S DIFILE=+DIFILE("STACK",DIFILE("STACK"))
 S DIFILE("INDEX")=$P(DIFILE("STACK",DIFILE("STACK")),U,3)
 Q
 

DICLIB
DICLIB ;SFISC/TKW - LIBRARY OF FUNCTIONS FOR ^DIC ;11/19/93  15:37
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NXTNO(F,DA,FLAGS) ;GET NEXT RECORD NUMBER FOR FILE OR SUBFILE F (F CAN CONTAIN A GLOBAL REFERENCE TO IMPROVE EFFICIENCY)
 ;DA=DA ARRAY (IF F IS A SUBFILE)
 ;FLAGS (OPTIONAL) IF IT CONTAINS "U", WILL UPDATE LAST REC.# ON 0 NODE
 N I,X,Y,DIC S X=0,I=1
 S:'F DIC=$TR(F,")",",") S:F DIC=$$ROOT^DIQGU(F,.DA)
 G:DIC="" QI G:'$D(@(DIC_"0)")) QI
INCR L @("+"_DIC_"0):10") G:'$T QL
 I 'X S Y=@(DIC_"0)"),X=$P($P(Y,U,3),".",1)
 F I=1:1 S X=X+1 Q:'$D(@(DIC_X_")"))  I I=100 S I=0 Q
 I 'I L @("-"_DIC_"0)") G INCR
 I $G(FLAGS)["U" S $P(@(DIC_"0)"),U,3,4)=X_U_($P(Y,U,4)+1)
 L @("-"_DIC_"0)")
 Q X
QI D BLD^DIALOG(200) G Q0
QL D BLD^DIALOG(110,F)
Q0 Q 0
 ;DIALOG #200  'An input variable or parameter is missing or invalid.'
 ;       #110  'The record is currently locked'

DICM
DICM ;SFISC/GFT,XAK-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;2/17/93 12:19 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S:'$D(DICR(1)) DICR=0 I $A(X)=34,X?.E1"""" G N
 G:$D(^DD(+DO(2),0,"LOOK")) @^("LOOK") I DIC(0)["U" S DD=0 G W
R S %="B",Y=+DO(2),%Y=.01,DD=0 G 1
Z S:%=-1 %="" S %=$O(^DD(+DO(2),0,"IX",%)) S:%="" %=-1 S Y=$O(^(%,0)) S:Y="" Y=-1 S %Y=$O(^(Y,0)),DD=1 S:%Y="" %Y=-1
1 G 2:Y<0,Z:$D(DICR(U,Y,%Y)),Z:D'=%&(DIC(0)'["M"),Z:'$D(^DD(Y,%Y,0)) S DICR(U,Y,%Y)=0,DS=^(0) I $D(^(7)) D RS K DS X ^(7) G Y
 S DIX=Y F Y="P","D","S","V",-1 I $P(DS,U,2)[Y D A D:'Y ^DICM1,D Q
Y G R:Y<0
2 G K:Y+1 I X?.E1L.E,DIC(0)'["X" D %,LC^DICM1 G K:Y+1
 S DS="",DIX=$P(X,",",1) F %=2:1 S DD=$P(X,",",%) I DD'["""" S:$A(DD)=32 DD=$E(DD,2,999) Q:$L(DD)*2+$L(DS)>200!(DD="")  S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))"
 I DS]"",DIC(0)'["X" D % S X=DIX,DS="S %=$P(^(0),U,1)"_DS,DIC(0)=DIC(0)_"D" D 7 G K:Y+1
 I $L(X)>30 D % S Y="DICR("_DICR_")",DS=$S(DIC(0)["X":"I $P(^(0),U,1)="_Y,1:"I '$L($P(^(0),"_Y_",1))"),X=$E(X,1,30) S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P($P(^(0),U),"_Y_",2))" D 7
K S DD=$D(DICR(DICR,6)) K:'DICR DICR
 I Y+1 K DIC("W") G R^DIC2
W D U G:'$T NL:DIC(0)["N",DD I DO(2)'["Z" S Y=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") S:Y="" Y=-1 Q:Y'>0  W:DIC(0)["E"&(DS#20=0) ".." I $D(^(Y,0)),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I  S DIY="" G GOT^DIC2
NL I '$D(DICR) D NQ G GOT^DIC2:$T
DD G B:DD
L I DIC(0)["L" K DD G ^DICN
B G O^DIC1
 ;
N D RS S X=$E(X,2,$L(X)-1),DS=^DD(+DO(2),.01,0),%=D,%Y=.01 F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 Q
 S Y=-1 D L:$D(X),E G B:Y<0,2
 ;
A G %:'DD I '$D(^DD(DIX,%Y,1,DD)) S DD=$O(^(DD)) G A:DD>0 S (DD,Y)=-1 Q
 I $S($D(^(DD,0)):$P(^(0),U,3,9)]"",1:1) S DD=DD+1 G A
% S DICR(DICR+1,4)=% I %'="B"!(DIC(0)'["L") S DICR(DICR+1,8)=1
 I $D(DF) S DICR(DICR+1,9)=DF K DF
RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DD="A" D DZ S DD="Q"
DZ S DIC(0)=$P(DIC(0),DD,1)_$P(DIC(0),DD,2) Q
 ;
D S (D,DF)=DICR(DICR,4),DD="M" S:D="B"&(DO(2)'["D") DIC(0)=DIC(0)_$S(DIC(0)["E"&(DO(2)["P"!(DO(2)["S")):"OX",1:"S") D DZ I $D(DS),$P(DS,U,2)["V" S DD="A" D DZ
RCR S:'$D(DIDA) DICRS=1
DIC ;
 I $D(DICR(DICR,8)) S DD="L" D DZ
 S Y=-1 I $D(X),$L(X)<31 D RENUM^DIC1 K DIDA
 S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF
E S D="B",%=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 S:$D(DICR(%,9)) (D,DF)=DICR(%,9) K DICRS,DICR(%) D DO^DIC1:'$D(DO) Q
 ;
U I @("$O("_DIC_"""A[""))=""""")
 Q
 ;
NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC
 Q
 ;
SOUNDEX I DIC(0)["E",'$D(DICRS) W "  " D RS,SOU S DD="L" D DZ,RCR Q:Y>0
 G R
 ;
7 S Y=-1,%=$S($D(DIC("S")):DIC("S"),1:1) I $D(DS),'$D(DIC("S1")) S DIC("S")=DS,DD="L" S:'% DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% D:X]"" DZ,F^DIC K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1")
 G E
 ;
SOU G SOU^DICM1

DICM0
DICM0 ;SF/XAK - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;3/9/95  15:35 ;
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
P ;Pointers, called by ^DICM1
 S DICR(DICR,1)=DIC,DIC=U_$P(DS,U,3),Y=DIC(0),(D,DIC(0))=$P(Y,"L",1)_$P(Y,"L",2),DICR(DICR,2)=$S(%="B":Y,1:D),DICR(DICR,2.1)=$S($P(DS,U,2)["'":D,1:Y)
 S DIC(0)=$P(D,"N",1)_$P(D,"N",2)
 F Y="DR","S","P","W" I $D(DIC(Y)) S DICR(DICR,Y)=DIC(Y) K DIC(Y)
AST G P1:$P(DS,U,2)'["*"
 F D=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(DS,D) I Y X $P($E(DS,1,Y-$L(D)-1),U,5,99) S:DS["DIC(0)=" DICR(DICR,2.1)=DIC(0) I $D(DIC("S")) S DICR(DICR,31)=DIC("S")
P1 S Y="("_DICR(DICR,1) G L1:'$D(DO) K DO I @("$O"_Y_"0))'>0") G L1
 S I="DIC"_DICR,D="X ""I 0"" F "_I_"=0:0 S "_I_"=$O"_Y,%=""""_%_"""" I @("$O"_Y_%_",0))>0") S D=D_%_",Y,"_I_")) Q:"_I_"'>0  I $D"_Y_I_",0))"
 E  I DS["DINUM=X" S D="I $D"_Y_"Y,0)) S "_I_"=Y"
 E  S D=D_I_")) Q:"_I_"'>0  I $P(^("_I_",0),U)=Y"
 I $D(DICR(DICR,31)) S D="X DICR("_DICR_",31) "_D
 I $D(DICR(DICR,"S")) S D=D_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I "
 S DIC("S")=D_" Q",D="B",Y=0 D X^DIC
L1 K DIC("S"),@("DIC"_DICR) I Y'>0,'$D(DICR(DICR,8)) S:$D(DICR(DICR,31)) DIC("S")=DICR(DICR,31) G RETRY
 I DICR(DICR,2)["L",DICR(DICR,2)["E",@("$P("_DIC_"0),U,2)'[""O"""),$P(@(DICR(DICR,1)_"0)"),U,2)'["O" S DST="         ...OK",%=1 D Y^DICN W:'$D(DDS) ! G:%-1 L2
R K DICS,DICW,DO,DIC("W"),DIC("S")
 S DIC=DICR(DICR,1),%=DICR(DICR,2),DIC(0)=$P(%,"M")_$P(%,"M",2)
 F X="DR","S","P","W" S:$D(DICR(DICR,X)) DIC(X)=DICR(DICR,X)
 I $D(DIC("P")),+DIC("P")=.12 S DIC(0)=DIC(0)_"X"
 D DO^DIC1 S X=+Y K:X'>0 X Q
 ;
L2 G NO:%-2 S DIC("S")="I Y-"_+Y_$S($D(DICR(DICR,31)):" "_DICR(DICR,31),1:""),X=DICR(DICR) W:'$D(DDS) "     "_X I $D(DDS),$G(DDH) D LIST^DDSU
 K DST ;
RETRY D DO^DIC1 K DICR(U,+DO(2)) S D="B",DIC(0)=DICR(DICR,2.1) D X^DIC K DICR(DICR,6)
 G R
 ;
NO S Y=-1 G R
 ;

DICM1
DICM1 ;SFISC/XAK-LOOKUP WHEN INPUT MUST BE TRANSFORMED ;10/4/94  11:03
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G @Y
 ;
P ;POINTERS
 G P^DICM0
 ;
D ;DATES
 I $S(X'?.N:1,$L(X)>15:0,1:X>49) S %DT=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""") F %="E","R" D DZ
 I  D ^%DT S X=Y K %DT I X>1 Q:DIC(0)'["E"  S DIDA=1 Q:$D(DDS)  W "   " G DT^DIQ
 K X Q
DZ S %DT=$P(%DT,%)_$P(%DT,%,2) Q
 ;
S ;SETS
 N A8,A9 I $P(DS,U,2)["*"!($D(DIC("S"))) D SC
 S DICR(DICR,1)=1,I=$P(DS,U,3),DD=$P(";"_I,";"_X_":",2) I DD]"" S Y=X X:$D(A9) A9 I  W:DIC(0)["E"&'$D(DDS) "  (",$P(DD,";",1),")" D SK Q
SS N DDH,DS S (DDH,DICMF,DS)=0
 F DICM=1:1 S DD=$P(I,";",DICM) Q:DD=""  I $P($P(DD,":",2),X)="" D
 . S Y=$P(DD,":"),DD=$P(DD,":",2) Q:DIC(0)["X"&(DD'=X)
 . I $D(A9) X A9 E  Q
 . I DIC(0)["O" S:DD=X DICMF=1 I DD'=X,DICMF=1 Q
 . S DDH=DDH+1,DDH(DDH,Y)=$S(Y=DDH:"",1:Y)_"   "_DD
 . S DS=DS+1,DS(DS)=Y_"^     "_DDH_"   "_DDH(DDH,Y)
 G:DDH=0 NO
 I DDH=1 S X=$O(DDH(1,"")) G SK
 G:DIC(0)'["E" NO
 I $D(DDS) S DD=DDH,DDD=2 K DDQ D LIST^DDSU K DDD,DDQ G:$D(DTOUT) NO
 I '$D(DDS) F  D  Q:DICM'="AGN"
 . F DICM=1:1:DDH W !,$P(DS(DICM),U,2,999)
 . W !,"CHOOSE 1-"_DDH_": "
 . R DIY:$S($D(DTIME):DTIME,1:300) E  Q
 . Q:U[DIY!(DIY[U)  I DIY?1.N,$D(DS(+DIY)) Q
 . W $C(7),"??" S DICM="AGN"
 G:'$D(DS(+DIY)) NO
 S X=$P(DS(DIY),U) G SK
 ;
NO K X,Y S Y=-1
SK K DIC("S") S:$D(A8) DIC("S")=A8
 K DDH,DICM,DICMF,DICMS
 Q
SC ;SCREENS ON SETS
 S:$D(DIC("S")) A8=DIC("S") Q:$P(DS,U,2)'["*"
 Q:'$D(^DD(+DO(2),.01,12.1))  X ^(12.1) Q:'$D(DIC("S"))
 S Y="("_DIC,I="DIC"_DICR,%=""""_%_"""",A9="X DIC(""S"")"
 Q:$G(DICR(DICR))?1"""".E1""""
 ;I DS["DINUM=X" S D=D_" E  I $D"_Y_"Y,0))" Q
 S A9=A9_" E  F "_I_"=0:0 S "_I_"=$O"_Y
 I @("$O"_Y_%_",0))'=""""") S A9=A9_%_",Y,"_I_")) Q:"_I_"=""""  "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$D"_Y_I_",0)) Q" Q
 S A9=A9_I_")) Q:'"_I_"  "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$P(^("_I_",0),U)=Y Q" Q
 ;
V ;VARIABLE POINTER
 I X["?BAD" K X Q
 D ^DICM2,DO^DIC1
 Q
 ;
LC ;
 Q:DIC(0)["X"  S DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
 S X=$$OUT^DIALOGU(X,"UC")
 G DIC^DICM
 ;
SOU ;
 S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y  I Y?1A S %=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I %-DIX,%-9 S DIX=% I % S X=X_% Q:$L(X)=4
 S X=$E(X_"000",1,4) K DSOU,DSOV Q
 ;
ACT ;
 S DIY=Y,DIY(1)=DIC,DIC("W")="",DIX=X
A X:$D(^DD(+DO(2),0,"ACT")) ^("ACT") I Y<0 S DIC=DIY(1),X=DIX K DIC("W"),DO Q
 I DO(2)["P" S DIC=U_$P(^DD(+DO(2),.01,0),U,3) K DO D DO^DIC1 I $D(@(DIC_+$P(Y,U,2)_",0)")) S Y=+$P(Y,U,2)_U_$P(^(0),U) G A
 S Y=DIY,DIC=DIY(1),X=DIX K DIC("W"),DO D DO^DIC1 Q

DICM2
DICM2 ;SFISC/XAK-LOOKUP FOR VAR PTR ;8/13/90  3:46 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 S DIVDO=+DO(2),DIVDIC=DIC,DIVY=%Y N DIADD,DS
 F %="DR","S","A","V" I $D(DIC(%)) S DIV(%)=DIC(%)
 K DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT S DIEX=X G ALL:X'["."
 I $P(X,".",2,999)="" S Y=-1 G Q
V S DIVP=$P(DIEX,"."),A9=1
 I DIVP="" G ALL
 I $D(^DD(DIVDO,DIVY,"V","P",DIVP)) S (DIVP,DIVPDIC)=+$O(^(DIVP,0)),DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"") G Q:'DIVPDIC S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q
 S DIVP2="",DIVP=$P(DIEX,".")
 F %=0:0 S DIVP2=$O(^DD(DIVDO,DIVY,"V","M",DIVP2)) Q:DIVP2=""  I $P(DIVP2,DIVP)="" S (DIVP,DIVPDIC)=+$O(^(DIVP2,0)),DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:""),X=$P(DIEX,".",2,999),A9=0 G Q:'DIVPDIC D ^DICM3 G Q:Y>0 S DIVP=$P(DIEX,".")
 F DIVP=0:0 S DIVP=+$O(^DD(DIVDO,DIVY,"V",DIVP)) Q:'DIVP  I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q:Y>0 S X=DIEX
 I A9 S X=DIEX,A9=0 G ALL
 K X G Q
ALL F DIVP1=0:0 S DIVP1=+$O(^DD(DIVDO,DIVY,"V","O",DIVP1)) Q:'DIVP1  S DIVP=+$O(^(DIVP1,0)) I $D(^DD(DIVDO,DIVY,"V",DIVP,0)) S DIVPDIC=^(0) D ^DICM3 G Q:Y>0!(%<0)!$D(DUOUT) S X=DIEX
 G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
 ;
 ;
Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
 K:Y<0 X S DICR(DICR,"V")=1
 F %="DR","S","A","V" I $D(DIV(%)) S DIC(%)=DIV(%)
QQ K:Y DICR(DICR,6)
 K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q
 ;
NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
 S DINAME=DIY Q:'DIY  S %=$P(DIY,";",2),DINAME="^"_%_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%=""
 I %["P"!(%["S")!(%["D") S C=$P(^DD(+%,.01,0),U,2),%YYY=DIY,%YY=Y,Y=DINAME D Y^DIQ S DINAME=Y,DIY=%YYY,Y=%YY,C="," K %YY,%YYY
 Q
DQ ;

DICM3
DICM3 ;SFISC/XAK-PROCESS INDIVIDUAL FILE FOR VAR PTR ;2/17/93 12:22 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIC ;
 Q:$D(DIVP(+DIVPDIC))
 I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 G DQ
 I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 G DQ
 S (Y,DIC)=^("GL"),%="DIC"_DICR
 I DIC["""" S Y="" F A1=1:1:$L(DIC,",")-1 S A0=$P(DIC,",",A1) S:A0["""" A0=$P(A0,"""")_""""""_$P(A0,"""",2)_""""""_$P(A0,"""",3) S Y=Y_A0_","
 S:DIC(0)'["L"!'$D(DICR(DICR,"V")) DIC("S")="X ""I 0"" F "_%_"=0:0 S "_%_"=$O("_DIVDIC_""""_D_""""_",(+Y_"";"_$E(Y,2,99)_"""),"_%_")) Q:"_%_"'>0  I $D("_DIVDIC_%_",0))"_$S($D(DIV("S")):" S %YV=Y,Y="_%_" X DIV(""S"") S Y=%YV I ",1:"")_" Q"
 S %=DIC(0),DIC(0)="DM"_$E("E",%["E")_$E("O",%["O") I D="B",$P(DIVPDIC,U,6)="y",$D(DICR(DICR,"V")),%["L" S DIC(0)=DIC(0)_"L"
 I $D(DICR(DICR,"V")),$P(DIVPDIC,U,5)="y",$D(^DD(DIVDO,DIVY,"V",DIVP,1)),^(1)]"" S %=$S($D(DIC("S")):DIC("S"),1:"") X ^(1) S DIC("S")=DIC("S")_" "_%
 I DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) D H1^DIE3
 I X?."?" S DZ=X_$E("?",'$D(DICR(DICR,"V"))) D DQ^DICQ S X=$S($D(DZ):DZ,1:"?"),Y=-1 G DQ
 D DO^DIC1
 S D="B" D X^DIC G DQ:$D(DUOUT) S X=+Y_";"_$E(DIC,2,99),%=1 K:Y<0 X
 I Y<0,DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) W !
 I '$D(DICR(DICR,"V")) K DICR("^",+DIVPDIC) S DIVP(+DIVPDIC)=0
 I Y>0,$D(DIVP1),DIC(0)["E",'$P(Y,U,3),$P(^DIC(+DIVPDIC,0),U,2)'["O" D S1^DIE3
DQ K A0,A1,DIC,DO S DIC=DIVDIC,D=$S($D(DICR(DICR,4)):DICR(DICR,4),1:"B"),DIC(0)=DICR(DICR,0) I $D(DIV("V")) S DIC("V")=DIV("V")
 Q

DICN
DICN ;SFISC/GFT,XAK-ADD NEW ENTRY ;3:04 PM  3 Sep 1996
 ;;21.0;VA FileMan;**12,19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D:'$D(DO) DO^DIC1 S DO(1)=1
 G:$S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1) B1
USR I $D(DD) S X=DD D N^DICN1 G I:$D(X),B
 D DS S DIX=X I X'?16.N,X?.NP,X,DIC(0)["E",'$D(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^DICN1 I $D(X) S DD=X G I
 S X=DIX D VAL G I:$D(X)
 S X=DIX
B G BAD^DIC1
B1 G USR:'DO(2),USR:$D(^DD(+DO(2),0,"UP")),USR:DO(2)=".12P" S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G B:'%,USR
 ;
1 I '$D(DIC("S")) S DST=$G(DST)_$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD")) S:$D(^DD(+DO(2),0,"UP")) DST=DST_$$EZBLD^DIALOG(8059,$O(^DD(^("UP"),0,"NM",0))) S DST=DST_")"
Y I $D(DDS) S A1="Q",DST=%_U_DST D H^DDSU Q
 W !,DST K DST
YN ;
 N %1 S %1=$$EZBLD^DIALOG(7001) S:'$D(%) %=0 W "? " W:(%>0) $P(%1,U,%),"// "
RX R %Y:$S($D(DTIME):DTIME,1:300) E  S DTOUT=1,%Y=U W $C(7)
 I %Y]""!'% S %=+$$PRS^DIALOGU(7001,%Y) S:(%<0&($A(%Y)'=94)) %=0
 I '%,%Y'?."?" W $C(7),"??",!?4,$$EZBLD^DIALOG(8040),": " G RX
 W:$X>73 ! W:% $S(%>0:"  ("_$P(%1,U,%)_")",1:"") Q
 ;
DS S DS=^DD(+DO(2),.01,0) Q
 ;
VAL I X'?.ANP K X Q
 I X["""" K X Q
 I $P(DS,U,2)'["N",$A(X)=45 K X Q
 I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q
 S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) N DICTST S DICTST=DS["+X=X"&(X?16.N) K:DICTST X X:'DICTST $P(DS,U,5,99) Q
 ;
I1 S DST=$C(7)_$$EZBLD^DIALOG(8060) S:'$D(DD) DST=DST_$$EZBLD^DIALOG(8061,Y) S %=$P(DO,U,1) I $L(DST)+$L(%)'>55 S DST=DST_$$EZBLD^DIALOG(8062,%) Q
 W:'$D(DDS) !,DST K A1 D:$D(DDS) H^DIC2 S DST="    "_$$EZBLD^DIALOG(8062,%) Q
 ;
I I DIC(0)["E",DO(2)'["A",DIC(0)'["W" S C=$P(^DD(+DO(2),.01,0),U,2),(DIX,Y)=X D Y^DIQ,I1 S %=0,Y=$P(DO,U,4)+1,X=DIX D 1 G OUT:$D(DTOUT),B:%-1
 G FILE:'$D(DD)
R D DS S DST="   "_$P(DS,U,1)_": " I '$D(DDS) W !,DST K DST R X:DTIME S:'$T X=U,DTOUT=1,Y=-1
 I $D(DDS) S A1="Q",DST="3^"_DST D H^DDSU S X=% I $D(DTOUT) S X=U,Y=-1
 G B:X[U,R:X="" D VAL I '$D(X) W $C(7) W:'$D(DDS) "??" G:'$D(^DD(+DO(2),.01,3)) R S DST="    "_^(3) W:'$D(DDS) !,DST D:$D(DDS) H^DDSU G R
FILE D:'$D(DO) DO^DIC1 I DO="0^-1" G OUT
 F DIX=0:0 S DIX=$O(^DD(+DO(2),.01,"LAYGO",DIX)) Q:DIX'>0  I $D(^(DIX,0)) X ^(0) I '$T G OUT
 I $P($G(^DD($$FNO^DILIBF(+DO(2)),0,"DI")),U,2)["Y",'$D(DIOVRD),'$G(DIFROM) G OUT
 S DIX=X
F1 S X=$P(DO,U,3) D INCR S X=X\DIY*DIY+DIY
 I $D(DINUM) S X=DINUM D INCR
F2 I $D(@(DIC_"X)")) S X=X\DIY*DIY+DIY G B:$D(DINUM),F2
 S Y=$P(DO,"^",2) I $D(DD) S X=DD
 E  I 'Y,DUZ(0)'="@" G LOCK
 I DIC(0)["E",'$D(DINUM),$D(^DD(+Y,.001,0)) G NUM^DICN1
LOCK L @("+"_DIC_"X):1") I $D(@(DIC_"X)"))!'$T L @("-"_DIC_"X)") G F1
 S ^(X,0)=DIX,DD=0 L @("-"_DIC_"X)") K D S:$D(DA)#2 D=DA S DA=X,X=DIX
 I $D(@(DIC_"0)")) S ^(0)=$P(^(0),"^",1,2)_"^"_DA_"^"_($P(^(0),"^",4)+1)
 D A
IX S DS=X,DD=$O(^DD(+DO(2),.01,1,DD)) S:DD="" DD=-1
 I DD>0 G RIX^DICN1:^(DD,0)["TRIGGER"!(^(0)["BULL") X ^(1) S X=DS G IX
 I DIC(0)["E"&($O(^DD(+DO(2),0,"ID",0))>0)!$D(DIC("DR")) G ^DICN1
D ;
 S Y=DA_"^"_X_"^1" S:$D(D)#2 DA=D G R^DIC2
 ;
INCR S DIY=1 I $P(DO,U,2)>1 F %=1:1:$L($P(X,".",2)) S DIY=DIY/10
 Q
OUT S Y=-1 G A^DIC:$D(DO(1))&'$D(DTOUT),Q^DIC2
 ;
A I $P(^DD(+DO(2),.01,0),U,2)'["a",DO(2)'["a" Q
 I DO(2)'["a",^("AUDIT")["e" Q
 D AUD^DIET
 Q
 ;#7001   Yes/No question
 ;#8040   Answer with 'Yes' or 'No'
 ;#8058   (the |entry number|
 ;#8059   for this |filename|
 ;#8060   Are you adding
 ;#8061   '|.01 field value|' as
 ;#8062   a new |filename|

DICN1
DICN1 ;SFISC/GFT-PROCESS DIC("DR") ;10/4/94  11:09
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DIDA,DICRS,Y,%RCR
 F Y="DIADD","I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S %RCR(Y)=""
 S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
 I $D(DIC("DR")) S DD=DIC("DR")
 E  S DD="",%=0,Y=0 F  S Y=$O(^DD(+DO(2),0,"ID",Y)) S:Y="" Y=-1 Q:Y'>0  D CKID I '$D(%) D W G BAD
 S %RCR="RCR^DICN1" D STORLIST^%RCR G D^DICN:$D(Y)<9
BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 G Q^DIC2
 K DO G A^DIC
 ;
CKID I $D(DUZ(0)),DUZ(0)'="@",$D(^DD(+DO(2),Y,9)),^(9)]"" F %=1:1 I DUZ(0)[$E(^(9),%) Q:$L(^(9))'<%  K:$P(^(0),U,2)["R" % G Q
 S DD=DD_Y_";"
Q Q
 ;
W S A1="T",DST="SORRY!  A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
 S A1="T",DST="BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD" W:'$D(DDS) !,?6 D H D:$D(DDS) LIST^DDSU
 S %RCR="D^DICN1" D STORLIST^%RCR Q
 ;
H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
 W DST K A1,DST Q
RCR ;
 K DR,DIADD,DQ,DG,DE,DO S DIE=DIC,DR=DD,DIE("W")=DZ K DIC I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
 S DIE("NO^")="OUTOK"
 D:$D(DDS) CLRMSG^DDS D ^DIE K DIE("W"),DIE("NO^")
 D:$D(DDS)
 . I $Y<IOSL D CLRMSG^DDS Q
 . D REFRESH^DDSUTL
A I '$D(DA) S Y(0)=0 Q
 Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))
ZAP S DIK=DIE,A1="T",DST=$C(7)_"   <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
 D ^DIK S Y(0)=0 K DST Q
 ;
D S DIE=DIC G ZAP
 ;
RIX ;
 K %RCR F %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S %RCR(%)=""
 S %RCR="RR^DICN1",DZ=^(1) D STORLIST^%RCR G IX^DICN
 ;
RR X DZ Q
 ;
NUM ;
 I '$D(DD),DIC="^DIC(",'$D(DO(3)) D DIC G F2^DICN
 S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X I X F %=1:1 D N Q:$D(X)  S X=0 Q:%>999  S X=%Y+DIY,%Y=X
 S DST="   "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": " S:X DST=DST_X_"// " I '$D(DDS) W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E  S DTOUT=1,Y=U W $C(7)
 I $D(DDS) S A1="Q",DST=3_U_DST D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
 I Y="?" G WR
 G BAD^DIC1:Y[U S:Y]"" X=Y D N I '$D(X) W $C(7) W:'$D(DDS) "??" G WR
 G LOCK^DICN
 ;
WR S DST="" S:$D(^DD(+DO(2),.001,3)) DST="     "_^(3)
 I '$D(DDS) W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST
 I $D(DDS) S A1=+Y D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU
 G F1^DICN
 ;
N X:$D(^DD(+$P(DO,U,2),.001,0)) $P(^(0),U,5,99) I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
 K X Q
 ;
DS I '$D(DISMN) S DISMN=1000 D OS^DII:'$D(DISYS) S DISMN=$S(+$P(^DD("OS",DISYS,0),U,2):$P(^(0),U,2),1:DISMN)
 Q
DIC ;
 S DO(3)=1
 I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) S DIY=.1,X=+$P(^(1),U) Q
 I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
 Q

DICOMP
DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;3:22 PM  25 Jun 1996
 ;;21.0;VA FileMan;**15**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S:$D(DICOMP)[0 DICOMP="" K K S K=0 F DLV=0:1 G A:'$D(J(DLV+1))
EN1 ;
 S K=0 F  S DLV=K,K=$O(I(K)) G K:K="",K:I'>0!'$D(J(K))!'$D(I(K\100*100))
EN ;
 S DLV=+DICOMP
K K K S K=0 I DLV F I=0:100 Q:I>DLV  S K=K+1,K(K)="",K(K,1)=I
A K DICO S I=DLV F  S I=$O(J(I)),DICO(1)=DLV Q:I=""  K:DLV I(I),J(I)
 S DPUNC=",'+-():[]!&\/*_=<>",DLV0=DLV\100*100,I=X,DIM=9.1,DIMW="" K X,DG,DIC,DATE,DPS,M,Y,W
 S DIC(0)="ZFO",Q="""",(M,DPS,DBOOL)=0,DICO=I,DICO(1)=DLV,DICO(0)=DLV\100*100 F %=0:100 Q:'$D(J(%))  S DG(%)=%
 G 0:" "[I!(+I=I)!(I'?.ANP)!(I?."?")!($E(I,$L(I))=":") I DPUNC[$E(I,1),$A(I)-40,$A(I)-39 G 0
G D I I X?.NP G:X="" N:I]"",^DICOMP1 I +X=X,X<1700!'$D(DATE(K-1))!'DBOOL G N:W'=":",N:$D(DPS(DPS,"$S"))
 G E:$L(X)>30,FUNC:W="(",N:X?1"$"1U
V I $D(DICOMPX(X))#2 D DATE^DICOMP0:$D(DICOMPX(X,"DATE")) S T=X,X=DICOMPX(X) G N:'$D(DICOMPX(T,U)) S T=DICOMPX(T,U),DICN=$P(T,U,2),T=+T,Y(0)=^DD(T,DICN,0),D=$P(Y(0),U,2) D S^DICOMP0 G N
E K Y D ^DICOMP0 G 0:+X'=X&'$D(Y)
N ;
 I X]"" S K=K+1,K(K)=X
 S I=$E(I,M,999),M=0 G G:$F(DPUNC,W)<2
 I W=":",'$D(DPS(DPS,"$S")) S I=$E(I,2,999) D I,M^DICOMPX,M^DICOMPW:$D(X) S W="" G N:$D(X),0
 S X=W,W="",M=2 G N:X=""
 G DPS:X=")",C:",:"[X,0:"+-'"[X&'$L($E(I,M,999)) I X="(" D ST G N
 S DBOOL="><]['=!&"[X,Y="[]!&/\_><*=" G N:Y'[X I $E(I,M,999)_W]"",$D(K(K)),")'"[K(K)!'$F(DPUNC,K(K)),$F(Y,W)<2 G N:K(K)'="'" S K(K)="'"_X,X="" G N:DBOOL
0 G 0^DICOMP1
 ;
I I $A(I,M+1)=34 S M=$F(I,Q,M+2)-1 G I:M>0 S W=0,M=999,X=U Q
MR F M=M+1:1 S W=$E(I,M) Q:DPUNC[W
 S X=$E(I,1,M-1) Q
 ;
C I DICO["SETDATA(" D SD^DICOMPZ G Q^DICOMP1:'$D(X)
 S DICF=X D DG S K(K+1,2)=0
 I $O(DPS(DPS,"$"))["$" S DPS(DPS)=DPS(DPS)_Y_DICF G N
 G 0:'$D(W(DPS)) S (W,W(DPS))=W(DPS)-1 K:W<2 W(DPS) S DPS(DPS)=" S X"_W_"="_Y_DPS(DPS) G N
 ;
DPS I DPS D DPS^DICOMPW G N:'$D(W(DPS+1))
 G 0
 ;
FUNC S Y=$O(^DD("FUNC","B",X,0)) S:Y="" Y=-1 I '$D(^DD("FUNC",Y,0)),X'?1N.N2A,X'?1"$"1U G V
 S DICF=X D ST I $D(^(1)) D 1 G B
 I DICF'?1"$"1U.U D ^DICOMPX S W="" G DPS:DPS,0
 S DPS(DPS,DICF)=DPS(DPS),DPS(DPS)=" S X="_DICF_W
B S M=M+1,W="" G 0:$E(I,M)=")",N
 ;
2 ;
 D ST
1 G ARG^DICOMPZ
 ;
ST ;
 S DPS=DPS+1,%="",Y=K
S I 'Y S X="",DPS(DPS)=$P(" S X="_%_"X",U,%]"") Q
 I K(Y)="" S Y=Y-1 G S
 I "'"[K(Y)!(K(Y)="+"),$S(Y=1:1,1:K(Y-1)?1P!(K(Y-1)="")) S %=K(Y)_%,K=K-1,Y=Y-1 G S
 D DG S DPS(DPS)="" I K(K)?1P!(K(K)?2P) S DPS(DPS)=" S Y="_%_"X,X="_Y_",X=X",DPS(DPS,U)=K(K)_"Y",K=K-1
 S:$D(DATE(K)) DPS(DPS,"DATE")=1 S:DBOOL DBOOL=0,DPS(DPS,"BOOL")=1
 S K(K+1,2)=0 Q
 ;
DG S (Y,DG(DLV0))=$G(DG(DLV0))+1,Y=DQI_Y_")",X=" S "_Y_"=X"

DICOMP0
DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2/17/93 12:38 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T,1)_$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
 I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y Q
L S T=DLV,DICN=X G M:'$D(J(T))
TRY S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" ",DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I 1",1:"S %=$P(^(0),U,2) I '%,%'[""m""")_$P(",Y-DA",U,DICO(1)=T&DA) D DICS^DICOMPY:DUZ(0)'="@"
R I X?1"#"1NP.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X
 D ^DIC G A:Y>0
N I $P(X,DG,1)="",X=DICN S X=$P(X,DG,2,9) G R
 I X="NUMBER" S Y=.001,Y(0)=0 G D
 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))
A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D  S W=$E(I,D+1)
 I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN W !?3,"By '"_DICN_"', do you mean "_DG_"'"_$P(Y,U,2)_"'" S %=1 D YN^DICN G BAD:%<0,N:%-1
 S M=D
X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX
D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y D DATE:D["D"&'$D(DPS(DPS,"INTERNAL"))
 I D["m"!D G MUL^DICOMPZ
 I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O
 I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q
 D G^DICOMPY
O Q:W=")"&$D(DPS(DPS,"INTERNAL"))  S T=J(T)
S ;
 S %=DLV0,DG=W=":"&'$D(DPS(DPS,$S)) I D["O",D'["P"!'DG,$D(^DD(T,DICN,2)) S DICF=X D ST^DICOMP S K=K+2,K(K-1)=X,K(K)=" S Y="_DICF_" X:$D(^DD("_T_","_DICN_",2)) ^(2) S X=Y" G DPS^DICOMPW
 I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$S($D(^DD("_T_","_DICN_",0)):$P(^(0),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59),1)"
 I D["V",'$D(DPS(DPS,"FILE")) S X=X_",C=$S(X="""":-1,'$D(@(U_$P(X,"";"",2)_""0)"")):-1,1:$P(^(0),U,2)),X=$S(X="""":X,'$D(^(+X,0)):"""",1:$P(^(0),U,1)),Y=X,C=$S($D(^DD(+C,.01,0)):$P(^(0),U,2),1:""D"") D:X]"""" Y^DIQ:C'[""D"" S X=Y,C="","""
 Q:D'["P"  S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2)
 I DG,$D(^DIC(DICN,0)) D DRW^DICOMPX S %1=Y,Y=DICN X:$D(^DIC(Y,0)) DIC("S") S Y=%1 K %1 G MR:'$T
 I 'DG S D=$S($D(^DD(DICN,.01,0)):$P(^(0),U,2),1:"") I D'["V",D'["S",D'["P" D DATE:D["D" S X="$S('$D("_%Y_"+"_X_",0)):"""",1:$P(^(0),U,1))" Q
P G P^DICOMPX
 ;
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
 G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) I T'="",$D(^DD("FUNC",T,3)),^(3)?1"0".E,$D(^(1)) D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$S($D(^(2)):^(2)?1"D".E,1:0),DPS^DICOMPW Q
 S T=-1,%DT="T" D ^%DT I Y>0 S X=Y,Y(0)=0 G DATE
 S T=$O(^DIC("B",X)) S:T="" T=-1 I $P(T,X,1)=""!$D(^(X)) S T=DLV0 D ^DICOMPV I D>0 G P:D=.01 Q
MR I M'>$L(I),+X'=X D MR^DICOMP G L
BAD K Y Q
 ;
DATE S DATE(K+1)=1

DICOMP1
DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2/17/93 12:45 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G 0:DPS
 I DICO["SETDATA(" S K=K+1,K(K)=DICF(1)_",DIC(DIG)=X D SD^DICR S X="""" K DIC"
 S DG=-1,T=99,M=DIM,DLV0=0,X="",K=1,W=0 K DIM
ST S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) I DG="" D EX S DG=-1,W=0 G NN
 I Y]"" S:+Y'=Y Y=Q_Y_Q S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D X:T-DG!(DG<DLV0) S I=I_Y_")):^("_Y_")" G 9
C S %=$O(DG(DLV0,DG,0)) S:%="" %=-1 I %>0 S I=" X $P(^DD("_J(DG)_","_%_",0),U,5,99) S "_DQI_DG(DLV0,DG,%)_")=X" D EX:W,M:$L(X)+$L(I)>180 S X=X_I K DG(DLV0,DG,%) G C
 G ST:$D(DG(DLV0,DG))[0 S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$S($D(D"_I_"):D"_I
 E  S I=DQI_+DG_")="_I
 K DG(DLV0,DG) G OV:DG?.N1A
9 S I=I_",1:"""")" I $D(DICV),DICV["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_""""
OV I $L(I)+$L(X)>180 D M
 S:'W X=X_" S " S X=X_I_",",W=2 G ST
 ;
X S I=$P(I,U),%=DG\100*100 F T=0:1:DG#100 S I=I_I(%)_$E(",",1,T)_$S(DICOMP["T"&(DG<DICO(0)):"I("_%_",0)",1:"D"_T)_",",%=%+1
 K DG(DLV0,DG) Q
 ;
NN I $D(K(K,1)) S W=0,DLV0=K(K,1),DG=-1 K K(K,1) G ST
 I $D(K(K,9)) F %=1:1:K K DATE(%)
 G S:$D(K(K))[0 I " "[$E(K(K),1) G K1:K(K)="",1:X="",AS:$P(K(K)," S ",1)="" D EX:W,M:$L(X)+$L(K(K))>180 G 1
 I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6
1 G P:K(K)?1P,A:'$D(DATE(K)) S Y=1 I K>1,K(K-1)="+" S X=X_"0,X2=X,X1="_K(K) G DTC
2 G A:'$D(K(K+2)) K DATE(K) I '$D(DATE(K+2)),$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1
 E  G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0
 S K=K+2
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
 ;
P I "\/"[K(K),$D(K(K+1)),K(K+1)'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")"
 I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX
A S W='$D(K(K,2)),X=X_K(K)
K1 S K=K+1 G NN:$D(K(K))#2
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")_")"
 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 G Q
0 ;
 S DICOMP="",DLV=DICO(1) K X,DIM,DATE I DICO[" ",DUZ(0)="@" S X=DICO,DIM=1 D ^DIM
Q I DICOMP'["S" S K=DICO(1) F  S K=$O(I(K)) Q:K=""  K I(K),J(K)
 K Y S Y=DLV_$E("W",$D(DPS("W")))_DIMW_$E("D",$D(DATE)>9)_$E("B",DBOOL)_$E("X",$D(DIM))_$E("L",$D(DICO(2)))
 K V,K,W,T,M,DG,DIM,DICN,DICF,DICV,DLV,DPS,DIC,DICOMP,DBOOL,DICO,DLV0,DPUNC,DICMX,DIMW Q
 ;
 ;
EX S X=$E(X,1,$L(X)-W+1) Q
 ;
AS D EX I $L(K(K))+$L(X)<160 S K(K)=$E(K(K),4,999),X=X_","
 E  D M
 G 1
 ;
M D SS,EX S M=M+.1,X(M)=X,X="X "_$S(DA:"^DD("_A_","_DA_",",1:DA)_M_")",W=0 Q
 ;
SS S:$A(X)=32 X=$E(X,2,999) Q
 ;
SX S X=X_" S X=X",W=1
 Q

DICOMPV
DICOMPV ;SFISC/GFT,XAK-EVALUATE COMPUTED FLD EXPR ;8/15/95  13:50
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D DRW^DICOMPX S T=DLV0,DD=0
DD S DD=$O(^DD(J(T),0,"PT",DD)) I DD'>0 S T=T-100,DD=0 G DD:T'<0 Q
 F Y=DD:0 G DD:'$D(^DD(Y,0)) Q:'$D(^(0,"UP"))  S Y=^("UP")
 I $D(^DIC(Y,0)),$P(^(0),X)="" X DIC("S") I $T,$D(^DIC(Y,0,"GL")) S V=^("GL"),D=0 F  S D=$O(^DD(J(T),0,"PT",DD,D)) S:D="" D=-1 Q:D'>0  D F G Y^DICOMPX:Y[U,Q:'$D(T)
 G DD
 ;
F I D=.01,DD=Y,$D(^DD(Y,.01,0)),$P(^(0),U,5,99)["DINUM=X" D YN I %=1 S %Y=V,X="D0" K T S:$D(DIFG) DIFG=1 G DICOMPX
 Q:'$D(DICMX)  S %=0 F  S %=$O(^DD(DD,D,1,%)) S:%="" %=-1 Q:%'>0  I $D(^(%,0)) S J=^(0) I +J=Y,$P(J,U,3,9)="" D YN G Q:%-1 S X=V D QQ^DICOMPX:X[Q G MP
 I DICOMP["?",$D(^DD(DD,D,0)) W $C(7),!,"THE '"_$P(^(0),U,1)_"' POINTER FROM FILE #"_DD,!?9,"IS NOT CROSS-REFERENCED",!
Q Q
 ;
YN S %=1 Q:DICOMP'["?"  W !?3,"By '"_DICN_"', do you mean the "_$P(^DIC(Y,0),U,1)_" File,"
 W !?7,"pointing via its '"_$P(^DD(DD,D,0),U,1),"' Field" S DICV=$P(^(0),U,2)
 D YN^DICN I %=1,DICOMP["W",$P($G(^DD(DD,0,"DI")),U,2)["Y" W !,$C(7),"SORRY, CAN'T EDIT A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!" S %=2
 Q
 ;
MP S DICN=$S(DA:DQI_(80+T),1:"I("_T_",0")_")",J=Q_$P(J,U,2)_Q,T=D S:$D(DIFG) DIFG=$P(J,Q,2)
 I DICOMP'["W" S D=Y,X=$P(^DD(D,.01,0),U,2) D X^DICOMPZ S D="S D=0 F  S (D,D0)=$O("_V_J_","_DICN_",D)) S:D="""" (D,D0)=-1 Q:D'>0  I $D("_V_"D,0)) "_X_" "_DICMX_" Q:'$D(D)  S D=D0" D DIM^DICOMPZ S X=X_" S X=""""" G POP
 D ASKE^DICOMPW I 'D,T-.01&'DS!(DD-Y) S D=0
 E  S DZ=0 D ASK^DICOMPW:'D I D<0 K T Q
 S %=D,D="S DIC="_Y_$S(%=2:",DIADD=1",1:"")_",DIC(0)="""_$P("EQ",U,DS)_$E("L",D>0)_$E("W",$D(DICO(3)))
 I T-.01 S D=D_$P("AM",U,DS)_""",DIC(""S"")=""I $D("_X_Q_J_Q_","_DICN_",Y))"" D ^DIC K DIADD S D0=+Y,DIC("_T_")="_DICN_",DIH="_Y_" D DICL^DICR:$P(Y,U,3) K DIC"
 E  S D=D_"U"",X="_DICN_" D ^DIC K DIC,DIADD S D0=+Y"
 D DIM^DICOMPZ I '% S %=":$O(^(D0))>0",X=" S D0=$O("_V_J_","_DICN_",0))"_$S(DS:X_%,1:" S"_%_" D0=0")
 S X=X_" S X=$S(D0>0:D0,1:"""")" S:$D(DICOMPX(0)) X=X_","_DICOMPX(0)_"0)=X"
POP S Y=Y_U,D=1
DICOMPX ;
 S DICN=+Y I $D(DICOMPX)#2 S DICOMPX=+Y_U_.01_$E(";",1,$L(DICOMPX))_DICOMPX
 Q

DICOMPW
DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5/17/93  12:29 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
COLON K DP S DICOMPW=DICOMP
 I $D(DIC)#2,$P(X,":",2)="" S X=$P(X,":"),DIC(0)="FIZO",DIC("S")="I $P(^(0),U,2)[""P"",'$P(^(0),U,2)" D ^DIC K DIC S X=X_":" D:Y>0 ARC I Y>0 S X="INTERNAL(#"_+Y_")",DP=+$P($P(Y(0),U,2),"P",2)_U_$P(Y(0),U,3),DICOMP=DICOMP_"S"
 E  S X=$E(X,1,$L(X)-1),DICOMPX="",DICOMPX(0)="D(",DICOMP=DICOMP_"S"
 D EN^DICOMP G Q:'$D(X)
 I $D(DP) S:$D(DIFG) DIFG=2 S DICOMP=DICOMPW D DRW^DICOMPX G Q:'$D(^DIC(+DP,0)) S D=Y,Y=+DP X DIC("S") S Y=D I '$T K X,DIC("S") G Q
 I $D(DP) F D=DICOMPW\100*100:1 S X="S I("_D_",0)=D"_(D#100)_" "_X I +DICOMPW=D S X=X_" S D(0)=+X",D=Y\100+1*100,I(D)=U_$P(DP,U,2),J(D)=+DP,Y=D_U_Y G Q
 S DP=+DICOMPX I Y>DICOMPW S %=I(+Y),DP=DP_$S(%[U:%,1:U_$P(%,"""",1)_$P(%,"""",2)) G Q
 K X
Q S:$D(DIFG)&$D(X) DIFG("DICOMP")=DICOMPX K DICOMP,DICOMPX,DICOMPW Q
 ;
M ;
 S (D,DS)=0,DZ="""",Y=J(DLV) I DICOMP["W" D ASKE,ASK:'D I D<0 K X Q
 S:DS DZ="E"""
 I D S DZ=$E("W",$D(DICO(3)))_"L"_DZ_$S(DLV=DLV0:"",1:",DIC(""P"")="""_$P(^DD(J(DLV-1),$O(^DD(J(DLV-1),"SB",J(DLV),0)),0),U,2)_"""") I D=2 S DZ=DZ_",X=""""""""_X_"""""""""
 S (%,%Y)=DLV#100,DZ=" K DIC S "_$P("Y=-1,",U,%>0)_"DIC="""_X_""",DIC(0)=""NMF"_DZ,X=" D ^DIC"_$P(":D"_(%-1)_">0",U,%>0)_" S (D,D"_%_$S($D(DICOMPX(0)):","_DICOMPX(0)_%_")",1:"")_")=+Y"
 I D F %=%:-1:1 S X=X_",DA("_%_")=DIU("_%_")",DZ=DZ_",DIU("_%_")=$S($D(DA("_%_")):DA("_%_"),1:0),DA("_%_")=D"_(%Y-%)
 S X=DZ_X
 I W=":" S M=M+1 Q
 S I="#.01"_$E(I,M,999),M=0 Q
 ;
ASKE ;
 S (D,DS)=0,%=1 I DICOMP["?",DICOMP["E" W !,"WILL TERMINAL USER BE ALLOWED TO SELECT PROPER ENTRY IN '"_$O(^DD(Y,0,"NM",0))_"' FILE" D YN^DICN S:%=1 DS=1
 S:%<0 D=% Q:%  D DICOMPW^DIQQQ G ASKE
 ;
ASK ;
 G NO:DICOMP'["?",ASK1:DUZ(0)="@"
 S DIFILE=Y,DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G:'% NO
ASK1 W !,"DO YOU WANT TO PERMIT ADDING A NEW '"_$O(^DD(Y,0,"NM",0))_"' ENTRY"
 S %=2-(DICOMP["L"),D=0 D YN^DICN W ! I %<1 S D=-1 Q
 Q:%=2  S D=1 Q:DZ  W "WELL THEN, DO YOU WANT TO **FORCE** ADDING A NEW ENTRY EVERY TIME"
 S %=2-(DICOMP["L2") D YN^DICN I %<1 S D=-1 Q
 S D=3-%,DICO(2)=1 Q:%=1!'DS
 W !,"DO YOU WANT AN 'ADDING A NEW "_$O(^DD(Y,0,"NM",0))_"' MESSAGE" D YN^DICN I %<1 S D=-1 Q
 Q:%=1  S DICO(3)=% Q
NO S D=0 Q
 ;
DPS ;
 S X=DPS(DPS),%=$O(DPS(DPS,"$")) S:M'>$L(I)!(DICO'?1"(".E) DBOOL=$D(DPS(DPS,"BOOL")) I %["$" S X=X_"X)"_DPS(DPS,%)
 I $D(DPS(DPS,"DATE")) S DATE(K+1)=1
 S %=$D(DATE(K)) I $D(DPS(DPS,U)) S K=K+2,K(K-1)=X,K(K)=$E(DPS(DPS,U),1),X=$E(DPS(DPS,U),2,99)
 I %&$D(DPS(DPS,"O"))!$D(DPS(DPS,"D"))!$D(DPS(DPS,"DATE")) S DATE(K+1)=1
 E  S K(K+1,9)=0
 K DPS(DPS) S DPS=DPS-1
 Q
ARC ;
 Q:DICOMP'["W"
 I $P($G(^DD(+$P($P(Y(0),U,2),"P",2),0,"DI")),U,2)["Y" W !,$C(7),"SORRY, CAN'T EDIT A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!" S Y=-1
 Q

DICOMPX
DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2/18/93 14:58 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S K(K+1)=X,I=$E(I,M+1,999) I "PREVIOUSNEXT"[DICF S M=0,(%X,D,T)=DLV0,X=I(DLV0) D REF,SV S V=X G S
 F M=2:1 I ":)"[$E(I,M) S X=$E(I,1,M-1) Q
 D MULARG
S G ^DICOMPY
 ;
MULARG I DICF="COUNT" S DIC("S")="I $P(^(0),U,2)" G MM
M ;
 S DIC("S")="I $P(^(0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""W"""
MM S DICN=X,T=DLV S:X?1"#".NP X=$E(X,2,9)
TRY S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " S:DG=" " DG="-1 " D DICS^DICOMPY,^DIC G R:Y<0
 F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D  S W=$E(I,D+1)
 I DICOMP["?",$P(Y,U,2)'=DICN W !?3,"By '"_DICN_"', do you mean the '"_$P(Y,U,2)_"' Subfield" S %=1 D YN^DICN I %-1 G R:%+1 K X Q
 S M=D,Y=+$P(Y(0),U,2),X=$P($P(Y(0),U,4),";",1) I +X'=X S X=Q_X_Q
 S (DLV,D)=DLV0+100 F %=T\100*100:1 Q:%>T  S J(DLV)=J(%),I(DLV)=I(%),DLV=DLV+1
 S I(DLV)=X,X=I(D),J(DLV)=Y D QQ,REF S DLV0=DLV0+100 F DLV=D:1:DLV D SN
 Q
 ;
REF F Y=D+1:1:DLV S V=Y#100-1,DICN=I(Y) S:DICN[Q DICN=Q_DICN_Q S X=X_$S(T<DLV0:"I("_(T\100*100+V)_",0)",1:"D"_V)_","_DICN_","
Q Q
 ;
R I $P(X,DG,1)="",X=DICN S X=$P(X,DG,2,9) G TRY
 S T=T-1 I T'<0 G TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1))
 S X=DICN,DIC=1 D DRW,^DIC I Y<0 K X Q
 S X=^(0,"GL") D QQ
Y S DLV0=DLV0+100,I(DLV0)=^DIC(+Y,0,"GL"),J(DLV0)=+Y F DLV=DLV+100:-1:DLV0 D SN
 Q
 ;
SN S %X=DLV0-100 D SV S DG(DLV0)=DLV Q
 ;
SV S (T,DG(%X))=DG(%X)+1,%=DLV#100,K(K+2,1)=DLV0,DG(%X,T)=%,M(%,%X+%)=T Q
 ;
QQ F %=0:0 S %=$F(X,Q,%) G Q:%<1 S X=$E(X,1,%-1)_$E(X,%-1,999),%=%+1
 ;
DRW ;
 S D=$S(DICOMP["W":"""WR""",1:"""RD""")
 S DIC("S")="S DIAC="_D_",DIFILE=+Y D ^DIAC I %"
 Q
 ;
P ;
 S DLV0=DLV0+100,I(DLV0)=%Y,J(DLV0)=DICN F DLV=DLV+100:-1:DLV0 D SN
 S X=" S D0="_X_" S:'$D("_%Y_"+D0,0)) D0=-1"
 I $D(DICOMPX(0)) S X=X_" S "_DICOMPX(0)_"0)=D0",DICOMPX(0,DICN)=""
 I DG S M=M+1,W="",%=$E(I,M,999) S:+%=% I=$E(I,1,M-1)_"#"_% Q
 S I="#.01"_$E(I,M,999),M=0,W=""

DICOMPY
DICOMPY ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2/18/93  15:00 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G BAD:'$D(X) S DG(DLV0)=DG(DLV0)+1,DICN=DQI_DG(DLV0)_")",W=DLV#100,K=K+2,%="D"_W,K(K)=" S "_DICN_"=""""",J=" X ""F "_%_"=0:0 S "_%_"=$O("_X_%_")) Q:"_%_"'>0  "
 S DIC("S")="I '$P(^(0),U,2)",DIC="^DD("_J(DLV)_",",D=M,M=$F(I,")")-1,X=$E(I,D+1,M-1) G BAD:M<1 S:X?1"#".NP X=$E(X,2,9) S:X="" X=.01
 I X="NUMBER" S D=%,%=W,W=D,D=$S($D(^DD(J(DLV),.001,0)):$P(^(0),U,2),1:"") G NUMBER
 D DICS,^DIC G BAD:Y<0
 S T=+Y,%=DLV-DLV0,D=$P(Y(0),U,2) I D["C" S W="X",J=J_"X $P(^DD("_J(DLV)_","_T_",0),U,5,99) " G NUMBER
 D W I X="" S W="D"_%
 E  S:+Y'=Y Y=Q_Q_Y_Q_Q S W="$S($D(^(D"_%_","_Y_")):",Y="(^("_Y_")," D EP S W=W_X_",1:"""""""")"
NUMBER I DICF S DG(DLV0)=DG(DLV0)+1,%X=DQI_DG(DLV0)_")",K(K)=" S X=0,"_%X_"=0"_K(K) D L S W=W_" "_%X_"="_%X_"+1 I "_%X_"="_+DICF_" S "_DICN_"=Y Q",DPS(DPS,"O")=""
 E  D @DICF
 I $D(DICOMPX)#2 S %X=J(DLV)_U_T_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%X) DICOMPX=%X_DICOMPX
 S W=W_""" S "_$S($D(DICOMPX(0)):"("_DICOMPX(0)_%_"),D("_%_")",1:"D("_%)_")=D"_%
 I DICF="COUNT" S DICN="+"_DICN
 S K=K+1,K(K)=J_W,K(K,2)=0,K=K+1,K(K)=DICN,M=M+1 I "TOTAL"=DICF!$T K DATE(K-2) Q
 Q:$D(DPS(DPS,"INTERNAL"))  I D["O",$D(^DD(J(DLV),T,2)) S K=K+1,K(K)=" S Y=X "_^(2),K(K,2)=0,K=K+1,K(K)="Y" Q
 S:D["D" DATE(K)=1 S X="X",DICN=T,T=J(DLV) D S^DICOMP0 Q:X="X"
 S K(K,2)=0,K=K+1,K(K)=X Q
 ;
W S X=$P(Y(0),U,4),Y=$P(X,";",1),X=$P(X,";",2) Q
 ;
DICS ;
 S:DUZ(0)'="@" D=DICOMP["W"+8,DIC("S")=DIC("S")_" Q:'$D("_DIC_"Y,"_D_"))  F %=1:1:$L(^("_D_")) I DUZ(0)[$E(^("_D_"),%) Q" Q
G ;
 D W I X="" S Y=T#100,X=$S(T<DLV0&$D(M(Y,T))!(DICOMP["T"&(T<DICO(0))):$S(DA:DQI_(T+80)_")",1:"I("_T_",0)"),1:"$S('$D(D"_Y_"):"""",D"_Y_"<0:"""",1:D"_Y_")") Q
 I '$D(DG(%,T_U_Y)) S (DG(%),DG(%,T_U_Y))=DG(%)+1
 S Y="("_DQI_DG(%,T_U_Y)_"),"
EP I X S X="$P"_Y_"U,"_X_")" Q
 I X?1"E".E S X="$E"_Y_+$E(X,2,9)_","_$P(X,",",2)_")"
 Q
 ;
BAD S DPS=0 Q
 ;
PREVIOUS S W="I $O("_V_"D"_%_"))=I("_DLV_",0) S "_DICN_"="_W_" Q" Q
NEXT S X=" S D"_%_"=+$O("_V_"D"_%_")) " I D["C" S X=X_"X $P(^"_$P(J,"X $P(^",2)
 S J=X_"S "_DICN_"=",W=W_" S:D"_%_"'>0 D"_%_"=-1,"_DICN_"=""" Q
MAXIMUM S %X="'>" G MM
MINIMUM S %X="'<"
MM D L S W=W_"&("_DICN_%X_"Y!'$L("_DICN_")) "_DICN_"=Y" Q
TOTAL S W="S "_DICN_"="_DICN_"+"_W Q
COUNT S W=$S($P(Y(0),U,2)["W":"S ",1:"S:"_W_"'?."""" """" ")_DICN_"="_DICN_"+1" Q
LAST D L S W=W_" "_DICN_"=Y" Q
L S W="S Y="_W_" S:Y'?."""" """"" S:D["D" DPS(DPS,"DATE")=1
 Q

DICOMPZ
DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5/17/93  12:33 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ARG ;
 S DPS(DPS,DICF)="",DPS(DPS)=" "_^(1)_DPS(DPS)_" S X=X" I $D(^(2)) S %=$P(^(2),U,1) I %]"" S DPS(DPS,%)=""
 I DPS=1,$D(^(10)),^(10)]"" S DPS(^(10))=""
 S %=$S($D(^(3)):^(3),1:0) G W:%?.N
 S %=1 F %Y=M+1:1 S Y=$E(I,%Y) Q:")"[Y  S:Y="," %=%+1
 S DPS(DPS)=" K X"_%_DPS(DPS)
W S:%>1 W(DPS)=% Q
 ;
MUL ;
 I $E(I,M,M+1)="'["!(W["[") G CNTNS
 I D S X=$P(^DD(+D,.01,0),U,2) G WP:X["W" D X G FOR
 S %=D,DIMW="m"_$E("w",%["w"),(DICN,D)=$P(Y(0),U,5,99) F Y=0:0 S Y=$F(D,"X DICMX",Y) Q:Y'>0  S D=$E(D,1,Y-8)_DICMX_$E(D,Y,999),Y=$L(DICMX)-7+Y
 I DICMX'="X DICMX",D=DICN S D=DICMX D DIM S D="S DICMX="_DA_DIM_") "_DICN
 I %["p" S Y=+$P(%,"p",2),(%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D DICOMPX^DICOMPV
DIM S DIM=DIM+.1,X(DIM)=D,X=" X "_$S(DA:"^DD("_A_","_DA_",",1:DA)_DIM_")" Q
 ;
X ;
 S X="S X=$P(^(0),U,1)"_$S(X["D":",Y=X D D^DIQ S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U,1)",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
 ;
WP S DIMW="m"_$E("w",X'["L")
M S X="S X=^(0)"
FOR S Y=T#100+1,D=$P($P(Y(0),U,4),";",1),X="D)) Q:D'>0  I $D(^(D,0))#2 "_X_" "_DICMX_" Q:'$D(D)  S D=D"_Y S:+D'=D D=Q_D_Q
 F T=T:-1:T\100*100 S X=$S(T<DLV0:"I("_T_",0)",1:"D"_(T#100))_","_D_","_X,D=I(T)
 S D="F D=0:0 S (D,D"_Y_")=$O("_D_X
 I DICOMP["I" S X=I(DLV0) D QQ^DICOMPX:X["""" S D="S I("_DLV0_")="""_X_""",J("_DLV0_")="_J(DLV0)_" "_D
 D DIM S X=X_":D"_(Y-1)_">0 S X="""""
 Q
 ;
CNTNS K DICF S:$D(DICMX) DICF=DICMX S DPS=DPS+1,DPS(DPS)=DG(DLV0)+1,DG(DLV0)=DPS(DPS)+1,DD=W="'",DICMX="I X["_DQI_DPS(DPS)_") S "_DQI_(DPS(DPS)+1)_")="_'DD_" K D"
 D M K DICMX S:$D(DICF) DICMX=DICF
 S DIMW="",I=$E(I,M+DD+1,999),DPS(DPS)=" S "_DQI_DPS(DPS)_")=X,"_DQI_(DPS(DPS)+1)_")="_DD_X_" S X="_DQI_(DPS(DPS)+1)_")" K Y D I^DICOMP,^DICOMP0:X]""
 I $D(Y) S K=K+1,K(K)=X,X=DPS(DPS),DBOOL=1
 S DPS=DPS-1
 Q
SD ;
 I +DICOMPX=200,$P(^DIC(200,0),U)="NEW PERSON" W:DICOMP["?" !?5,"CANNOT SET DATA INTO THE NEW PERSON FILE" K X Q
 I +DICOMPX=3,$P(^DIC(3,0),U)="USER" W:DICOMP["?" !?5,"CANNOT SET DATA INTO THE USER FILE" K X Q
 I $P($G(^DD(+DICOMPX,0,"DI")),U,2)["Y" W:DICOMP["?" !?5,"CANNOT SET DATA INTO A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE" K X Q
 S %=$P($P(DICO,",",$L(DICO,",")),")") I $A(%)=34,"^@"[$E(%,2) W:DICOMP["?" !?5,"CANNOT SET "_%_" INTO A FIELD" K X Q
 S DICF=I(DLV0)
 I $P(^DD(+DICOMPX,+$P(DICOMPX,U,2),0),U,2)["C" W:DICOMP["?" !?5,"CANNOT SET DATA INTO A COMPUTED FIELD" K X Q
 I $P($P(^(0),U,4),";",2),%[U W:DICOMP["?" !?5,"CANNOT SET A VALUE WHICH CONTAINS AN '^' INTO A FIELD" K X Q
 S DICF(1)=0 F %=DLV0:0 S %=$O(I(%)) Q:%'>0  S DICF=DICF_"D"_(%#10-1)_","_$E(Q,I(%)[Q)_I(%)_$E(Q,I(%)[Q)_",",DICF(1)=DICF(1)+1
 S %=" S DA=D"_DICF(1),Y=0
 I DICF(1)>0 F DICF(1)=DICF(1)-1:-1:0 S Y=Y+1,%=%_",DA("_Y_")=D"_DICF(1)
 S DICF(1)=%_",DIH="_+DICOMPX_",DIG="_+$P(DICOMPX,U,2)_",DIC="_Q_DICF_Q
 Q

DICQ
DICQ ;SFISC/XAK-HELP FOR LOOKUPS ;12/21/94  12:44
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DZ=X D:DIC(0)]"" DQ
 I '$D(DDS),$D(DDH)#2,DDH D ^DDSU
 S:$D(DZ) X=DZ K DZ,DDH,DIZ,DDD G NO^DIC:$D(DTOUT),A^DIC
 ;
DQ S DDC=$S($D(DDS):7,1:15),DDH=$S($D(DDH):DDH,1:0)
 D:'$D(DO) DO^DIC1 K DS,%Y I DO="0^-1" K DO S DST="  Pointed-to File does not exist!" D % Q
 S DD="",Y=$P(DO,U,4),DIY=DO,DIX=D D DIY
 S X=$S($D(^DD(+DO(2),.001,0)):$P(^(0),U,1),DIC(0)["N":"NUMBER",1:""),DIZ=X]"",DIW=^DD(+DO(2),.01,0)
 S DIW=$P(DIW,U,2,3) G:$D(^DD(+DO(2),0,"QUES")) @^("QUES") I DIZ S DS=.001 D DS
IX S X=$O(^DD(+DO(2),0,"IX",DIX,"")) S:X="" %=DO(2) I X]"" S DS=$O(^(X,0)) I $D(^DD(X,DS,0)) S:+DO(2)'=X DS=X_" "_DS S %=$P(^(0),U,2,3),X=$P(^(0),U) D DS
 I @("$D("_DIC_"DIX))>9!$D(DF)"),DD="" S DD=DIX,DIW=% S:'Y Y=2 S:'$D(^(DD)) Y=0,DIZ=0
 S DIX=$O(^(DIX)) G IX:DIC(0)["M"&(DIX]"")
 I DD="" S DIZ=1 S:$O(^("AZ"))]"" Y=0
 I $D(DZ)#2 G C:DZ["??" S:DZ["BAD" Y=0
 S DST=$$EZBLD^DIALOG(8063,$P(DO,U)) S DS=0
 F X=1:1 S DS=$O(DS(DS)) Q:DS=""  S:X>1!$G(DS(0)) DST=DST_$$EZBLD^DIALOG(8067) D:$L(DST)+$L(DS(DS))>70 N S DST=DST_" "_DS(DS)
 K DS S DST=DST_$E(":",Y) D % G 0:'Y
20 G C:Y<11 S DDH=DDH+1,DDH(DDH,"Q")=0_U_$$EZBLD^DIALOG(8064)_$S(DO(2)'["s"&'$D(DIC("S"))&'$D(DF):$$EZBLD^DIALOG(8065,Y),1:"")_$$EZBLD^DIALOG(8066,$P(DO,U))
 S:$D(DDS) DDD=1 D ^DDSU I '$D(DDS) Q:$D(DTOUT)  G 21
 Q:$D(DDSQ)  S %=1
21 S A1="T",DDH=$S($D(DDH):DDH,1:0) S:%=1 %Y=1 I %Y'="??" S %Y=$E(%Y,2,99) S:%=2&(DIC(0)["L") DZ=""
 G 0:%#2=0!(%<0&(%Y="")),C:%Y=""
 S DIZ=$S(+%Y=%Y:1,DD]"":0,1:DIZ) I +%Y'=%Y G 20:DD="" I $P(DIW,U,1)["D" S DS=Y,X=%Y,%DT="T" D ^%DT K %DT S %Y=Y,Y=DS,DIZ=0 I %Y<0 S DST=$C(7) D % G 20
C I Y>1,$D(DZ)#2 S DST=" " D:DZ["??"&'$D(DDS) % S DST=$$EZBLD^DIALOG(8068) D %
 S X=$P(" D S I ",U,$D(DIC("S"))!$D(DO("SCR")))
 I DIZ S DS="I $D(^(Y,0))#2,'$D(^(-9)) S X=$P(^(0),""^"",1)"_X_" S DDH=DDH+1,DDH(DDH,Y)=Y_$E(DIEQ,1,15-$L(Y))_"" """,DIX="S Y=$O("_DIC_"Y)) S:Y="""" Y=-1 I Y'>0" G A
 S DIX="S X=$O("_DIC_""""_DD_""",X)) I X="""""
 S DS=$S(X]""!$D(DIC("W"))!($G(DZ)["?"):"S Y=0 F  S Y=$O("_DIC_""""_DD_""",X,Y)) Q:'Y "_$P(" I $D(^(Y))#2,'^(Y)",1,DD="B")_" I $D("_DIC_"Y,0)),'$D(^(-9))"_X_" D CHK Q:$D(DICQ1Q) ",1:"I 1")_" S DDH=DDH+1"
A S X="X"
D S Y=$P(DIW,U,1) I Y["D" S DIY=27,X=" S %="_X_"_U_"_DIZ_" D DT" G ^DICQ1
 I Y["P" S DIY=U_$P(DIW,U,2),X="$S($D("_DIY_X_",0))#2:$P(^(0),""^"",1),1:"_X_")" I @("$D("_DIY_"0))") S DIY=^(0) D DIY S DIW=$P(^(0),U,2,3) G D
 I Y["S" S DS(95)=";"_$P(DIW,U,2),X="$P($P(DS(95),"";""_"_X_"_"":"",2),"";"")"
 I Y["V" S X=" S %Y=Y,Y=X,C=$P(^DD(+DO(2),.01,0),U,2) D Y^DIQ S DDH(DDH,%Y)=$S($D(DDH(DDH,%Y)):DDH(DDH,%Y),1:"""")_"" ""_Y S Y=%Y" G ^DICQ1
 S X=" S DDH(DDH,Y)=$G(DDH(DDH,Y))"_"_"_X
M G ^DICQ1
 ;
N D % S DST="    " Q
 ;
% S DDH=DDH+1,DDH(DDH,"T")=DST K DST Q
 ;
0 K DIW,DIZ,DS Q:$D(DTOUT)  S:$D(DDS) DDD=1 G 0^DICQ1:DIC(0)["L" Q  ;END
 ;
DIY S DIY=$P(^DD(+$P(DIY,U,2),.01,0),"$L(X)>",2),DIY=$S(DIY:DIY,1:30)+7 Q
 ;
SOUNDEX G IX
 ;
DS S:DO'[X DS(DS)=X I DO[X,$G(DZ)'["??" S DS(0)=1
 ;
 ;#8063  Answer with |Filename|
 ;#8064  Do you want the entire
 ;#8065  |Number of entries| Entry
 ;#8066  |Filename| List
 ;#8067  , or
 ;#8068  Choose from

DICQ1
DICQ1 ;SFISC/GFT-HELP FOR LOOKUPS ;6/24/94  13:47
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN K DDD I $D(DDH)>10 S:$D(DDS) DDD=1 D LIST^DDSU Q:$D(DDSQ)
 S Y=$S('$D(%Y):0,%Y:%Y-.00000001,1:%Y)
 I $L(DS)+$L(X)<240 S DS=DS_X G N
 E  S DS=DS_" X DS(3)",DS(3)=$S($E(X)=" ":$E(X,2,999),1:X)
N S X="" I DIZ S DIY=$L($P(DO,U,3))+DIY+5 S:Y="" Y=0
 E  S X=$S(Y=0:"",1:Y),Y=0
 D:$D(DIC("W")) ID S DDD=5,DIY=99,DIEQ="",$P(DIEQ," ",40)=" ",DIZ=DDC
 I '$D(DDS) D Z^DDSU
 ;
L X DIX I  D BK^DIEQ S:'$D(DDS) DDD=3 D LIST^DDSU K DDH Q:$D(DDSQ)  G 0
 X DS I $D(DICQ1Q) K DICQ1Q Q:$D(DTOUT)!$D(DDSQ)  G:'$D(DDH) 0
 I $D(DDS),DDH'<DIZ S DIZ=DDH+DDC D LIST^DDSU Q:$D(DDSQ)
 I '$D(DDS),DDH'<DDC D LIST^DDSU Q:$D(DTOUT)  G:'$D(DDH) 0
 G L
CHK ;Called by code in DS at line L+1 when we're doing a lookup with
 ;a DIC("S") and/or DIC("W") defined.
 I $D(DDS),DDH'<DIZ S DIZ=DDH+DDC D LIST^DDSU I $D(DDSQ) S DICQ1Q=1
 I '$D(DDS),DDH'<DDC D LIST^DDSU I $D(DTOUT)!'$D(DDH) S DICQ1Q=1
 Q
 ;
ID S DIY="I $D("_DIC_"Y,0)) "
 I $L(DIC("W"))+$L(DIY)<240 S DDH("ID")=DIY_DIC("W") Q
 S DDH("ID")=DIY_"X DDH(""ID"",1)" S DDH("ID",1)=DIC("W") Q
 ;
WOV S %DIC=DIC,%WW=Y,DIC=%Z,Y=%Y,%X=0
W1 S %X=$O(^DD(%W,0,"ID",%X)) I %X]"" S %=^(%X) X "W ""  "",$E("_%Z_%Y_",0),0)",% G W1
 S DIC=%DIC,Y=%WW K %DIC,%W,%X,%YY,%Z,%WW Q
 ;
S S DS(1)=X,DS(2)=Y I 1 X:$D(DIC("S")) DIC("S")
 I $T S Y=DS(2) D SCR:$D(DO("SCR"))
 S X=DS(1),Y=DS(2) Q
 ;
SCR I @("$D("_DIC_"Y,0))") X DO("SCR")
 Q
 ;
DT S A2=$P(%,U,2),%=$P(%,U),A1="" ;I $G(DUZ("LANG"))>1 S A1=$$OUT^DIALOGU(%,"DD"),DDH(DDH,Y)=$S(A2:DDH(DDH,Y),1:"")_A1 Q
 ;S:$E(%,4,5) A1=$E(%,4,5)_"-" S:$E(%,6,7) A1=A1_$E(%,6,7)_"-" S A1=A1_($E(%,1,3)+1700)
 ;S:%["." A1=A1_" @ "_$E(%_0,9,10)_":"_$E(%_"000",11,12)_$S(+$E(%,13,14):":"_$E(%_0,13,14),1:"   ")
 S DDH(DDH,Y)=$S(A2:DDH(DDH,Y),1:"")_$$FMTE^DILIBF(%,6) Q
 ;
0 ;
 K DDC,DIEQ,DIW,DS G:DIC(0)'["L" QQ
 S DDH=$S($D(DDH):DDH,1:0) K A1
 I $D(%Y) S:%Y="??" DZ=%Y S:%Y?1P DZ="?"
 I $S($D(DLAYGO):DO(2)-DLAYGO\1,1:1),DUZ(0)'="@",'$D(^DD(+DO(2),0,"UP")) G JMP
10 I DZ="?" S DST=$$EZBLD^DIALOG(8069,$P(DO,U)) D DS^DIEQ,HP
 D H
 I $D(DZ),DO(2)["S" S DST=$$EZBLD^DIALOG(8068)_" " D %^DICQ F X=1:1 S Y=$P($P(^DD(+DO(2),.01,0),U,3),";",X) Q:Y=""  S A2="",$P(A2," ",15-$L(Y))=" ",DST="  "_$P(Y,":",1)_A2_" "_$P(Y,":",2) D DS^DIEQ
 I DO(2)["V" S DU=+DO(2),D=.01 D V^DIEQ
 ;
RCR G:DO(2)'["P"!($G(DZ(1))=0) QQ
 N D,DIC
 S D="B",DS=^DD(+DO(2),.01,0),DIC=U_$P(DS,U,3),DIC(0)=$E("L",$P(DS,U,2)'["'")
 I $P(DS,U,2)["*" F DILCV=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S DICP=$F(DS,DILCV) I DICP X $P($E(DS,1,DICP-$L(DILCV)-1),U,5,99) Q
 K DICP,DILCV,DO D DQ^DICQ K DICW,DICS,DO
QQ K A1,A2,DST Q:$D(DDH)'>10
 S:$D(DDS) DDC=-1 D LIST^DDSU K DDC Q
 ;
HP F DG=3,12 I $D(^DD(+DO(2),.01,DG)) S X=^(DG) F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<70 S DST=$P(X," ",1,%) D DS^DIEQ,P1 Q
 Q
 ;
P1 I %'=$L(X," ") S DST=$P(X," ",%+1,99) D DS^DIEQ
 Q
 ;
H S %=DIC,X=DZ N DIC,D,DP S DIC=%,D=.01,DP=+DO(2) D H^DIEQ Q
 ;
JMP S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G RCR:'%,10
 ;
Q K A1,A2 Q
 ;
 ;#8069  You may enter a new |filename|, if you wish
 ;#8068  Choose from

DICR
DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;4/17/89  11:05 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DIU]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIU Q:'DIW  I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,2)) S DB(0,DIH,DIG,DIW,2)=1 D SAVE X ^(2) D RESTORE
 I DIV]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIV Q:'DIW  I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,1)) S DB(0,DIH,DIG,DIW,1)=1 D SAVE X ^(1) D RESTORE
Q Q
 ;
SAVE F DB=1:1 Q:'$D(DB(DB))
 F Y="DIC","DIV","DA" S %="" F DB=DB:0 S @("%=$O("_Y_"(%))") Q:%=""  S DB(DB,Y,%)=@(Y_"(%)")
 F %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR" S DB(DB,%)="" I $D(@%)#2 S DB(DB,%)=@%
 K DA F Y=-1:1 Q:'$D(DIV(Y+1))
 I Y+1 S DA=DIV(Y) F %=Y-1:-1:0 S DA(Y-%)=DIV(%)
 Q
 ;
RESTORE F DB=1:1 Q:'$D(DB(DB+1))
 F Y="DIC","DIV","DA" K @Y S %="" F DB=DB:0 S %=$O(DB(DB,Y,%)) Q:%=""  S @(Y_"(%)=DB(DB,Y,%)")
 S Y="" F %=0:0 S Y=$O(DB(DB,Y)) Q:Y=""  S @Y=DB(DB,Y)
 K DB(DB) K:DB=1 DB Q
 ;
DICL N I
 K DIC("S"),DLAYGO I '$P(Y,U,3) K DIC Q
DICADD ;
 S (D0,DIV(0))=+Y,DIV(U)=Y
 I DIC S DIH=DIC,DIC=^DIC(DIC,0,"GL")
 E  S @("DIH=+$P("_DIC_"0),U,2)")
 S DICR=$S($D(DA)#2:DA,1:0),DA=D0 F DIG=.001:0 S DIG=$O(DIC(DIG)) Q:DIG'>0  D U:DIC(DIG)]""
 S DA=DICR,Y=DIV(U) K DIC Q
 ;
U S %=$P(^DD(DIH,DIG,0),U,4),Y=$P(%,";",2),%=$P(%,";",1),X="",DIV=DIC(DIG) I @("$D("_DIC_DIV(0)_",%))") S X=^(%)
 G P:Y,Q:Y'?1"E"1N.NP S D=+$E(Y,2,9),Y=$P(Y,",",2),DIU=$E(X,D,Y) I DIU?." " S DIU="" S:$L(X)+1<D X=X_$J("",D-1-$L(X))
 S ^(%)=$E(X,1,D-1)_DIV_$E(X,Y+1,999)
 G DICR
P S DIU=$P(X,U,Y),$P(^(%),U,Y)=DIV
 G DICR
CONV ;
 K DA F %=0:1 Q:'$D(@("D"_%))
 S %=%-1 I '% S DA=D0 K % Q
 S DA=@("D"_%),%=%-1,Y=0
 F %1=%:-1:0 S Y=Y+1,DA(Y)=@("D"_%1)
 K %,%1,Y
 Q
SD ;
 S DIV(0)=DA D U K DA,DIH,DIG,DIV Q

DICRW
DICRW ;SFISC/XAK-SELECT A FILE ;11:24 AM  15 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
R D DT S D="OUTPUT FROM",DIC(0)="QEI",DIA=$S($D(^DISV(DUZ,"^DIC(")):^("^DIC("),1:"")
 D R1,DIC K DIAC,DIFILE,DIC("S") Q:$D(DTOUT)  G R:'$T,AU:+Y=1.1,A:+Y=.6
R2 I DUZ(0)'="@" S DICS="I 1 Q:'$D(^(8))  F DW=1:1:$L(^(8)) I DUZ(0)[$E(^(8),DW) Q"
 K DIA Q
 ;
AU S D="AUDIT FROM",DIC(0)="QEI" S:'$D(DIC("S")) DIC("S")="I Y>1.1"
 S:DIA ^DISV(DUZ,"^DIC(")=DIA D DIC Q:'$D(DIC)  G AU:Y<0
 I '$D(DDA),'$D(^DIA(+Y,0))#2 W $C(7),"   NO AUDIT ENTRIES" G AU
 S DIA=+Y,Y="1.1^"_$P(Y,U,2)_" AUDIT",DIC="^DIA(DIA,"
 Q
A S:'$D(DIC("S")) DIC("S")="S DIFILE=Y,DIAC=""DD"" D ^DIAC I %",DDA=""
 D AU Q:'$D(DIC)
 S %=$P(^DIC(DIA,0),U),Y=DIA D SUB I DIA'>0!$D(DTOUT)!$D(DUOUT) K DIC Q
 I '$D(^DDA(DIA,0)) W !,"  No DD AUDIT entries!" K DIC Q
 S Y=".6^"_$P(Y,U,2)_"DD AUDIT",DIC="^DDA(DIA,"
 Q
SUB I $D(DIT) S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y,Y=-1
 S DIC="^DD("_Y_"," Q:$O(^DD(Y,"SB",0))'>0  Q:$D(DIT)
 S DIC(0)="AEQIZ",DIC("A")="Select "_%_" SUB-FILE: "
 S DIC("S")="I $P(^(0),U,2)" D ^DIC Q:Y<0!$D(DTOUT)  S Y=+$P(Y(0),U,2)
 S DIA=Y,%=$P($P(^DD(DIA,0),U)," SUB-FIELD")
 I $D(DIT) S X=$P($P(Y(0),U,4),";",1),DSUB(L)=$S(X:X,1:""""_X_"""")_","
 G SUB
R1 S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
 Q
DT ;
 I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO=""
 E  W:'$G(DIQUIET) !
 S:$D(DUZ)#2-1 DUZ=0 S:$D(DUZ(0))#2-1 DUZ(0)="" S X=DUZ(0)="@" D 1
 I '$D(DTIME) S DTIME=300
 K %DT,DT S:$D(IO(0))[0 IO(0)=$I D NOW^%DTC S DT=X,U="^"
 K DIK,DIC,%I,DICS Q
 ;
0 S X=0
1 D:'$D(DISYS) OS^DII
 Q
W D DT S D=$S('$D(DDS1):"INPUT TO",1:DDS1),DIC(0)=$E("L",$D(DLAYGO)>0)_"EQI"
 D W1,DIC Q:$T!($D(DTOUT))  G W:'$P(Y,U,3) K DIC Q
W1 S DIC("S")="I Y>.19,Y-1,Y-1.1,Y-.6,Y-.403,Y-.404 S DIFILE=+Y,DIAC=""WR"" D ^DIAC I %"
 Q
DIC W ! S U="^",D=D_" WHAT FILE: ",DIC="^DIC("
 I DUZ(0)'="@",DIC(0)'["L",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) S DIC=$S($D(^VA(200,"AFOF")):"^VA(200,",1:DIC_"3,")_"DUZ,""FOF"","
 I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_Y_",0)")) X:$D(DIC("S")) DIC("S") I  S Y=Y_U_$P(^DIC(Y,0),U),D=D_$P(Y,U,2)_"// "
 W D S %=$T R X:DTIME E  W $C(7) S X=U,DTOUT=1,Y=-1 K DIC Q
 I '$D(@(DIC_"0)")) W "  There are no selectable files." K DIC S Y=-1 Q
 S:DIC["FOF" DIC(0)=DIC(0)_"O" I X="",% G WW
 S DIC("W")=$P($T(WW1),";",3) D ^DIC I $D(DTOUT) K DIC Q
GOT I $D(^DIC(+Y,0,"GL")) K DIC S DIC=^("GL") Q
 I U[X K DIC
 Q
WW S A9=$P($T(WW1),";",3) X A9
 K A9
 G GOT
 ;
D D DT S D="MODIFY",DIC(0)="LQEI",DIC("S")="I Y'<2 S DIFILE=+Y,DIAC=""DD"" D ^DIAC I %"
 D DIC S:DUZ(0)'="@" DICS="I 1 Q:'$D(^(9))  Q:^(9)=U  F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q"
 Q:$T!($D(DTOUT))  G D:'$P(Y,U,3) K DIC
 Q
DIAR ;
 D DT S D=$S($D(DIAX):"EXTRACT",1:"ARCHIVE")_" FROM",DIC(0)="QEI" D R1 S DIC("S")="I Y'<2 "_DIC("S")
 D DIC G R2:$D(DTOUT)!(X="^")!(X="")!(Y>0&($P($G(^DD(+Y,0,"DI")),U)'["Y"))
 W:$P($G(^DD(+Y,0,"DI")),U)["Y" !,$C(7),"SORRY, THIS IS ALREADY AN ARCHIVE FILE!"
 G DIAR
 Q
T ; COMP/MERGE
 D DT S D="COMPARE ENTRIES IN",DIC=1,DIC(0)="QEI" D W1,DIC Q:$T!($D(DTOUT))  G T
 ;
WW1 ;;W:$X>53 !?9 I Y-1.1,Y-.6,$D(^DIC(Y,0,"GL")),^("GL")'["[",$D(@(^("GL")_"0)")) S %=+$P(^(0),U,4) W ?40,"  ("_%_" entr"_$P("ies^y",U,%=1+1)_")"

DICRW1
DICRW1 ;SFISC/XAK-SELECT A FILE ;1/30/91  4:18 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
L ;LIST DD'S
 S DIB(1)=0 S D=" START WITH" D C2 G C4:U[X&(Y<0),L:Y<0
C3 S D="      GO TO" D C2 G C3:Y<0&(X'[U)
 I Y<DIB(1),X'[U W $C(7),!," The 'START WITH' File Number must be less than the 'GO TO' File Number." G L
C4 I X[U!'$D(DIC) K DIC Q
 S X=DIB(1),DIB(1)=+Y,Y=X Q
C2 D R1^DICRW D:$D(DDUC) DU S DIC(0)="QEI" D DIC^DICRW K DIAC,DIFILE Q:X[U!'$D(DIC)!(Y=-1)  S:DIB(1)=0 DIB(1)=+Y Q
DU S DIC("S")="I Y'<2 "_DIC("S")
 Q

DICU
DICU ;SEA/TOAD-VA FileMan: Lookup Utilities ;5/8/96  16:41
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12022;3150917;2921;
 
REQIDS(DIFILE,DITARGET) ;
 ; return REQUIRED IDENTIFIERS file attribute
 ; DIFILE = file#, DITARGET = target array
 N DIATTRBT S DIATTRBT="REQUIRED IDENTIFIERS"
 S @DITARGET@(DIATTRBT,.01)=""
 N DIFIELD
 S DIFIELD=0 F  S DIFIELD=$O(^DD(DIFILE,0,"ID",DIFIELD)) Q:'DIFIELD  D
 . I $D(^DD(DIFILE,"RQ",DIFIELD)) S @DITARGET@(DIATTRBT,DIFIELD)=""
 Q
 
RID(DIFILE) ;
 ; return a string listing a file's required identifiers
 ; DIFILE = file#
 N DILIST S DILIST=".01"
 N DID S DID="" F  S DID=$O(^DD(DIFILE,0,"ID",DID)) Q:'DID  D
 . I $D(^DD(DIFILE,"RQ",DID)) S DILIST=DILIST_U_DID
 Q DILIST
 
RECALL(DIFILE,DIEN,DIUSER) 
RECALLX ;input from DILFD
 
 ;ENTRY POINT--save a user's selection for use with space-bar recall
 ;procedure, all passed by value
 
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
 
30 S DIFILE=$G(DIFILE)
 I +DIFILE'=DIFILE!(DIFILE<0) D ERR(202,,,,"file") Q
 S DIEN=$G(DIEN) I DIEN="" S DIEN=","
 I '$$IEN^DIDU1(DIEN) D ERR(202,,,,"IEN string") Q
 S DIUSER=+$G(DIUSER)
 
32 N DIOROOT,DIOUT S DIOUT=0 D  I DIOUT Q
 . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) S DIOUT=1 Q
 . S DIOROOT=$$ROOT^DILFD(DIFILE,DIEN,"Q")
 . I DIOROOT'?1"^"1U.7UN1"(".ANP,DIOROOT'?1"^%".7UN1"(".ANP D  Q
 . . D ERR(402,DIFILE,,,,,,DIOROOT) S DIOUT=1
 S ^DISV(DIUSER,$E(DIOROOT,1,28))=$E(DIOROOT,29,$L(DIOROOT))_+DIEN
 I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 Q
 
FILE(DIFILE,DIDA,DIFLAGS,DIROOT) 
 ; entry point -- given a root, calculate the file # and DA
 ; DO NOT USE UNTIL $QS & $QL AVAILABLE
 N DIGLOBAL I $G(DIFLAGS)'["O" S DIGLOBAL=DIROOT
 E  S DIGLOBAL=$$CREF^DIQGU(DIROOT),DIROOT=DIGLOBAL
 S DIFILE=+$P($G(@DIGLOBAL@(0)),U,2),DIDA=""
 N DA,DIENTRY S DA=1,DIENTRY=0
 
LOOP N DICHAR,DIL,DILEAD,DIQL,DIQS,DIQSL F  D  Q:'DIQL
 .
STRIP .
 . ; S DIQL=$QL(DIGLOBAL) Q:'DIQL
 . ; S DIQS=$QS(DIGLOBAL,DIQL)
 . N DIQSL S DIQSL=$L(DIQS)+1 I +DIQS'=DIQS S DIQSL=DIQSL+2
 . S DIL=$L(DIGLOBAL),DILEAD=DIL-DIQSL
 . S $E(DIGLOBAL,DILEAD+1,DIL-1)=""
 . S DICHAR=$E(DIGLOBAL,DILEAD)
 . I DICHAR="," S $E(DIGLOBAL,DILEAD)=""
 . E  I DICHAR="(" S $E(DIGLOBAL,DILEAD,DILEAD+1)=""
 . E  S DIGLOBAL="ERROR:  "_DIGLOBAL,DIQL=0
 .
ENTRY . I DIENTRY D
 . . S DIFILE(DA)=+$P($G(@DIGLOBAL@(0)),U,2)
 . . S DIROOT(DA)=DIGLOBAL
 . . S DIDA(DA)=DIQS,DA=DA+1
 . S DIENTRY='DIENTRY
 Q
 
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3,DIROOT) 
 
 ; error logging procedure
 ; RECALL
 
 N DIPE,DI
 F DI="FILE","IENS","FIELD",1:1:3,"ROOT" S DIPE(DI)=$G(@("DI"_DI))
 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 Q

DICU1
DICU1 ;SEA/TOAD-VA FileMan: Lookup Tools, Get IDs ;10/8/96  08:49
 ;;21.0;VA FileMan;**17,8,31**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12183;5299469;4726;
 
IDENTS(DIFILE,DIFIELD,DIROOT,DIDS,DIWRITE,DIDENT) 
 ; ENTRY POINT--return array of identifiers and code to build them
 ; proc, DIDENT by reference
 N DICODE,DICRSR,DIDEF,DIEFROM,DIETO
 N DINODE,DIOUTI,DIPIECE,DISTORE,DITYPE,DIUSEKEY
 I DIFLAGS'["S" D
 . S DIUSEKEY=DIFIELD'=.01!(DIFILE'=$G(DIFILE("INDEX"),DIFILE))
 . S DIDENT=DIUSEKEY*.01
 E  S DIUSEKEY=0,DIDENT=0
 S DICRSR=1
ID0 F  D  Q:DIDENT=""!$G(DIERR)  S DICRSR=DICRSR+1
 . I 'DIUSEKEY D
 . . I DIDS'="" S DIDENT=$P(DIDS,";",DICRSR) Q
 . . S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT)) Q
 . I DIUSEKEY S DIUSEKEY=0,DICRSR=0
 . I DIDENT="" S DIOUTI=1 D  Q:DIOUTI
 . . Q:DIDS=""
 . . S DIDS=""
 . . S DIDENT=$O(^DD(DIFILE,0,"ID"," "),-1),DIDENT=$O(^(DIDENT))
 . . S DIOUTI=DIDENT=""
 . . Q
 . I DIDS="",DIFIELD=DIDENT,DIFILE=DIFILE("INDEX") Q
IDFIELD .
 . I DIDENT D  Q:$G(DIERR)
 . . S DINODE=$G(^DD(DIFILE,0,"ID",DIDENT))
 . . I DIDS="",DINODE="W """"" Q
 . . D GET(DIFILE,DIDENT,.DIDEF,.DICODE)
 . . Q:$G(DIERR)
 . . S DITYPE=$P(DIDEF,U,2)
 . . I DIDEF="" Q
 . . N DIVAR
 . . S DIVAR=$S(DIFLAGS'["P":"DIDENT(DIDENT)",1:"DIDENT(DICRSR,DIDENT)")
 . . S @DIVAR=DICODE
 . . S DITYPE=$S(DITYPE["C":"C",DITYPE["D":"D",DITYPE["S":"S",1:DITYPE)
 . . S @DIVAR@("TYPE")=DITYPE
 . . I DITYPE["S" D
 . . . S @DIVAR@("CODE")=";"_$P(DIDEF,U,3)
IDWRITE .
 . E  D
 . . S DICODE=$G(^DD(DIFILE,0,"ID",DIDENT))
 . . I DICODE'="" D
 . . . I DIFLAGS'["P" S DIDENT(DIDENT)="N DIMSG "_DICODE
 . . . E  S DIDENT(DICRSR,DIDENT)="N DIMSG "_DICODE
 . . Q
 . Q
 Q:$G(DIERR)
 I DIWRITE'="" D
 . I DIFLAGS'["P" S DIDENT("ZZZ ID")="N DIMSG "_DIWRITE
 . E  S DIDENT(DICRSR,"ZZZ ID")="N DIMSG "_DIWRITE
 Q
 
GET(DIFILE,DIFIELD,DIDEF,DICODE) 
 N DINODE,DIPIECE,DISTORE,DIEFROM,DIETO
 I DIFIELD=.001 S DICODE="DIEN",DIDEF="" Q
 S DIDEF=$G(^DD(DIFILE,DIFIELD,0))
 I DIDEF="" D ERR(501,DIFILE,"","",DIFIELD) Q
 
G1 N DITYPE S DITYPE=$P(DIDEF,U,2)
 I DITYPE D  Q
 . I $P($G(^DD(+DITYPE,.01,0)),U,2)["W" S DITYPE="Word-processing"
 . E  S DITYPE="Multiple"
 . D ERR(520,DIFILE,"",DIFIELD,DITYPE)
 I DITYPE["C" D  Q
 . S DICODE=$P(DIDEF,U,5,9999)
 . S DIDEF=$P(DIDEF,U,1,4)
 
G2 S DISTORE=$P(DIDEF,U,4)
 S DINODE=$P(DISTORE,";")
 S DIPIECE=$P(DISTORE,";",2)
 I DINODE="",$P(DIPIECE,"E")'="",'DIPIECE S (DICODE,DIDEF)="" Q
 S DINODE="$G(@DIROOT@(+DIEN,"""_DINODE_"""))"
 I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
 E  D
 . S DIEFROM=$P($E(DIPIECE,2,9999),",")
 . S DIETO=$P(DIPIECE,",",2)
 . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
 Q
 
INDEX(DIFILE,DINDEX,DIROOT,DILISTER) 
 ; lookup data on a file's index
 S DINDEX("CODE")=""
 S DINDEX("FIELD")=""
 S DINDEX("TYPE")=""
 S DIFILE("INDEX")=$O(^DD(DIFILE,0,"IX",DINDEX,""))
 I DIFILE("INDEX") D
 . S DINDEX("FIELD")=$O(^DD(DIFILE,0,"IX",DINDEX,DIFILE("INDEX"),""))
 E  I $G(DILISTER) D
 . S DIFILE("INDEX")=DIFILE
 . I DINDEX="B" S DINDEX("FIELD")=.01
 . E  S DINDEX("GET")="DIENTRY"
 I $G(DILISTER),DINDEX="B",'$D(@DIROOT@("B")) S DIFILE("NO B")=1 D
 . D TMPIX^DICU2(DIROOT)
I1 I DINDEX("FIELD") N DIXNODE D
 . N DIXGET
 . D GET(DIFILE("INDEX"),DINDEX("FIELD"),.DIXNODE,.DIXGET)
 . S DINDEX("GET")=DIXGET
 . S DINDEX("TYPE")=$P(DIXNODE,U,2)
 I DINDEX("TYPE")["D" S DINDEX("TYPE")="D"
 I DINDEX("TYPE")["S" D
 . S DINDEX("TYPE")="S"
 . S DINDEX("CODE")=";"_$P(DIXNODE,U,3)
 S DINDEX("NODE")=$G(DIXNODE)
 I DINDEX("TYPE")["P" D
 . S DINDEX("TYPE")="P"
 . S DINDEX("PTR")=+$P($P(DIXNODE,U,2),"P",2)
 Q
 
BOTH(DIFILE,DIFLAGS,DIROOT,DINDEX,DIFIELDS,DIWRITE,DIDENT) 
 ; IXANDID^DICL--get index and identifier info
 D INDEX(.DIFILE,.DINDEX,DIROOT,1) Q:$G(DIERR)
 Q:DIFLAGS["f"
 D IDENTS(.DIFILE,DINDEX("FIELD"),DIROOT,DIFIELDS,DIWRITE,.DIDENT)
 Q
 
ERR(DIERN,DIFILE,DIENS,DIFIELD,DI1) 
 N DIPE
 S DIPE("FILE")=$G(DIFILE)
 S DIPE("IEN")=$G(DIENS)
 S DIPE("FIELD")=$G(DIFIELD)
 S DIPE(1)=$G(DI1)
 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 Q
 
 
FIELD(DIFILE,DIFIELD,DINDEX) 
 ; return code to fetch field value prior to screen execution
 I DIFIELD=.01 Q "DIKEY"
 N DISTORE S DISTORE=$P(DINDEX(0,"DEF"),U,4)
 N DINODE S DINODE=$P(DISTORE,";")
 N DIPIECE S DIPIECE=$P(DISTORE,";",2)
 I 'DINODE,$P(DIPIECE,"E")'="",'DIPIECE Q "X"
 I DINODE=0 S DINODE="DINODE"
 E  S DINODE="$G(@DIROOT@(+DIEN,"""_DINODE_"""))"
 N DICODE I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
 E  D
 . N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",")
 . N DIETO S DIETO=$P(DIPIECE,",",2)
 . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
 Q DICODE

DICU2
DICU2 ;SEA/TOAD-VA FileMan: Lookup Tools, Return IDs ;7/19/95  18:00 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11832;3636148;
 
IDS(DIFILE,DIEN,DIFLAGS,DIVALUE,DIROOT,DINDEX,DICOUNT,DIDENT,DILIST,DINODE) 
 ; ENTRY POINT--add an entry's identifiers to a list
 ; proc, DIEN, DINDEX, & DIDENT by reference
 N DICODE,DIDT,DIDVAL
 I DIFLAGS["P" N DICRSR,DILENGTH,DISAVE,DISUB D
 . S DICRSR="",DILENGTH=$L(DINODE(0)),DISAVE="",DISUB=0
 N DID,DIOUT S DID="",DIOUT=0 F  D  Q:DIOUT!$G(DIERR)
 . I DIFLAGS["P" S DID=DISAVE
 . S DID=$O(DIDENT(DID))
 . I DID="" S DIOUT=1 Q
 . I DIFLAGS["P" S (DICRSR,DISAVE)=DID,DID=$O(DIDENT(DICRSR,""))
 . I DID D
I0 . . N DIVAR
 . . S DIVAR=$S(DIFLAGS'["P":"DIDENT(DID)",1:"DIDENT(DICRSR,DID)")
 . . S DIDT=@DIVAR@("TYPE")
 . . S DICODE=$G(@DIVAR@("CODE"))
 . . I DIDT'="C" D
 . . . S @("DIDVAL="_@DIVAR)
 . . . I DIFLAGS'[1 S DIDVAL=$$FORMAT(DIFILE,DID,"I",DIDVAL,DIDT,DICODE)
I1 . . E  D
 . . . N %,%H,%T,A,B,C,D,DFN,I,X,X1,X2,Y,Z,Z0,Z1
 . . . N DA M DA=DIEN S DA=$P(DIEN,",")
 . . . N DIARG S DIARG="D0"
 . . . N DIMAX S DIMAX=$O(DA(""),-1)
 . . . N DIDVAR F DIDVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIDVAR
 . . . N @DIARG F DIDVAR=0:1:DIMAX-1 S @("D"_DIDVAR)=DA(DIMAX-DIDVAR)
 . . . S @("D"_DIMAX)=DA
 . . . X @DIVAR S DIDVAL=X
 . . I DIFLAGS'["P" S @DILIST@("ID",DICOUNT,DID)=DIDVAL
I2 . . E  D ADD(.DINODE,.DISUB,.DILENGTH,DIDVAL)
 .
 . E  D
 . . N %,D,DIC,X,Y,Y1
 . . S D=DINDEX
 . . S DIC=DIROOT("O")
 . . S DIC(0)=$TR(DIFLAGS,"fglpqtuv1")
 . . S X=DIVALUE
 . . M Y=DIEN S Y=$P(DIEN,",")
 . . S Y1=$G(@DIROOT@(+DIEN,0)),Y1=DIEN
 . . N DIX D
 . . . I DIFLAGS'["P" S DIX=DIDENT(DID)
 . . . E  S DIX=DIDENT(DICRSR,DID)
 . . X DIX ;***** NAKED *****
I3 . . I $G(DIERR) D
 . . . N DICONTXT I DID="ZZZ ID" S DICONTXT="Identifier parameter"
 . . . E  S DICONTXT="MUMPS Identifier"
 . . . D ERR^DICF6(120,DIFILE,DIEN,"",DICONTXT)
 I '$G(DIERR) D
 . I DIFLAGS'["P" M @DILIST@("ID","WRITE",DICOUNT)=^TMP("DIMSG",$J) Q
 . N DI S DI="" F  S DI=$O(^TMP("DIMSG",$J,DI)) Q:DI=""  D
 . . D ADD(.DINODE,.DISUB,.DILENGTH,$G(^TMP("DIMSG",$J,DI)))
 K DIMSG,^TMP("DIMSG",$J)
 Q
 
FORMAT(DIFILE,DIFIELD,DIFLAG,DIVALUE,DITYPE,DICODE,DIENTRY) ;
 I DIVALUE="" Q ""
 I DITYPE=$TR(DITYPE,"DOPSV") Q DIVALUE
 Q $$EXTERNAL^DIDU(DIFILE,DIFIELD,"",DIVALUE)
 
 
ADD(DINODE,DISUB,DILENGTH,DINEW) 
 ; sub, add DINEW to DINODE, overflowing if need be
 N DINEWLEN S DINEWLEN=$L(DINEW)
 S DILENGTH=DILENGTH+1+DINEWLEN
 I DILENGTH>255 S DISUB=DISUB+1,DILENGTH=DINEWLEN,DINODE(DISUB)=DINEW Q
 S DINODE(DISUB)=DINODE(DISUB)_U_DINEW
 Q
 
TMPIX(DIROOT) 
 ; called by INDEX^DICU1
 ; builds a temporary B index on files that lack them
 ; DIROOT = global root of file to be temporarily indexed
 N DIENTRY,DIVALUE
 S DIENTRY=0 F  S DIENTRY=$O(@DIROOT@(DIENTRY)) Q:'DIENTRY  D
 . S DIVALUE=$P($G(@DIROOT@(DIENTRY,0)),U) Q:DIVALUE=""
 . S @DIROOT@("B",DIVALUE,DIENTRY)=""
 Q

DID
DID ;SFISC/XAK-LIST DD'S ;10:11 AM  16 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D KL,L^DICRW1 I $D(DIC) S (DUB,DIB,DFF)=+Y G O:Y'=+DIB(1),SUB
KL K DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
 K DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
 K DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1 Q
 ;
SUB S DIC="^DD("_+Y_"," G O:$O(^DD(+Y,"SB",0))'>0 S DIC(0)="AEQZ",DIC("A")="      Select SUB-FILE: ",DIC("S")="I $P(^(0),U,2)" D ^DIC G KL:$D(DTOUT) I Y>0 S (DFF,Y)=+$P(Y(0),U,2) G SUB
 G KL:X[U
O K DIC S:DFF-DUB DIC("S")="I Y-5" S DIC="^DOPT(""DID"",",DIC(0)="AEQ",DIC("B")=1 D ^DIC G KL:Y<0
O1 K DIC S DIC="^DD(DFF,"
 I +Y=3 S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC",DIOBEG="S L=0 I $D(DQI),DQI,$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0))_"""" FILE """""",^(2)=""X ^(1.5) ""_^(2)" D EN^DIP G KL
 I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U
 S L=0,FLDS="",BY="@.001" I +Y=5 S (FR,TO)=.01,DHIT="S F(1)=DUB",DHD="W """" D H1^DIDG",DIOEND="D T^DID" G G
 S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID"
 I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG"
 I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX Q:%<1
 I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID"
G Q:DIB=0  S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL
LOOP I $D(Y),Y=U Q
 X DIOEND(1) I $D(M),M=U Q
 I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q
 S DN=1,D0=0,DIB=$O(^DIC(+DIB)) Q:DIB>DIB(1)!(+DIB'=DIB)  S (F(1),DUB,DFF)=DIB,DC="," D ^DIO2 I $D(M),M=U Q
 G LOOP
 ;
END ;
 I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC
D K ^UTILITY($J,"P") G IOF:DHIT["DIDX"
T ;
 S S=0,M=1
T1 S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U
 W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
 S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
 F  S DA=$O(@DFF@("F"_F(1),DA)) Q:DA=""  D  Q:M=U
 . S DUB=0 F  S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB  D  Q:M=U
 .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
 K %1 G Q:M=U,T1:S<4
IOF W:IOST'?1"C".E @IOF Q
 ;
TEMPL I $Y+3>IOSL D HDR^DIDG Q:M=U
 W !,$P(%1,U),?30 G:DFF["DIST" FORM
 S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y
 W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" "
 I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W "   ",?IOM-%-1,$E(Y,1,IOM-4)
 G DES:DFF'="^DIBT"
 I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y
 I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99)
 F Y=1:1 Q:'$D(^DIBT(DUB,"O",Y,0))  W "  " S %=^(0),D=IOM-$L(%)-5 W:$X>D !?$S(D>55:55,1:D) W %
DES N A1,%1,X S A1=$P($G(@(DFF_"(DUB,""%D"",0)")),U,3) F %1=0:0 S %1=$O(@(DFF_"(DUB,""%D"",%1)")) Q:%1'>0  Q:+A1&(%1>A1)  S X=^(%1,0) W !,?5,X
Q W:DFF["DIBT" ! Q
DT G DT^DIO2
 ;
EN ;
 Q:'$D(DIC)  I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2)
 Q:'DIC!'$D(^DIC(DIC,0,"GL"))  S (DFF,DUB,DIB,DIB(1))=DIC
 G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0))
 Q:Y>7!'Y  G O1
 ;
FORM ;
 S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y
 W ?50,"USER #"_+$P(%1,U,4)
 ;
 N B,L,P
 S L=1,L(1)=U
 S P=0 F  S P=$O(^DIST(.403,DUB,40,P)) Q:'P  D  Q:M=U
 . Q:$D(^DIST(.403,DUB,40,P,0))[0  S B=$P(^(0),U,2) D:B BLOCK  Q:M=U
 . S B=0 F  S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B  D BLOCK  Q:M=U
 S %1=0 F  S %1=$O(@DFF@(DUB,15,%1)) Q:'%1  W:$D(^(%1,0))#2 !?5,^(0)
 W !
 Q
BLOCK ;
 N I
 F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
 S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
 Q:$D(^DIST(.404,B,0))[0  S %1=^(0)
 ;
 I $Y+3>IOSL D HDR^DIDG Q:M=U
 W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2)
BLOCKQ Q
 ;
FILELST(DIDROOT) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DIDARRAY
 D EN4^DIQGDD
 M @DIDROOT=DIDARRAY
 Q
 ;
FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 G EN2^DIQGDD
 ;
FIELDLST(DIDROOT) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DIDARRAY
 D EN5^DIQGDD
 M @DIDROOT=DIDARRAY
 Q
 ;
FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 G EN1^DIQGDD
 ;
GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 G EN3^DIQGDD
 ;
PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
 ;PROCEDURE CALL AND  * * RETURN RESULTS IN TARGET ARRAY * *
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 G EN6^DIQGDD0

DID1
DID1 ;SFISC/XAK,JLT-STD DD LIST ;12/16/94  4:27 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DJ(Z)=D0,DDL1=14,DDL2=32 G B
 ;
L S DJ(Z)=0
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
B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E  G ND
 D HD:$Y+6>IOSL Q:M=U  W !!,F(Z),",",DJ(Z)
 W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4)
 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=""
 F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" W ?40," "_W G ND:M=U
 I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U
 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
 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
 S W=" ** TO AN UNDEFINED FILE ** " W:($L(W)+$X)'<IOM ! D W G ND:M=U
MP I X'["V" D RT^DIDX G:M=U ND
S I X["S" S N=$P(N,U,3) F %1=1:1 S Y=$P(N,";",%1) Q:Y=""  W ! S W="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2)_"; " D W G ND:M=U
 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
 I "Q"'[$P(N,U,5) W !?DDL1,"INPUT TRANSFORM:" S W=$P(N,U,5,99) D W G ND:M=U
 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
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
 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)_"(#"_%_"), " I %'>0 D W G ND:M=U Q
 S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X
 D L
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
 S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:"
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
 S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR
IX S F=0 F  S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0  G ND:M=U W !?DDL1,"CROSS-REFERENCE:" D IX1
 S:F="" F=-1
ND S X="" G:M'=U A:Z>1 Q
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
 Q:'$D(^("%D"))  N X,%,W S %=$P($G(^DD(F(Z),DJ(Z),1,F,"%D",0)),U,3),X=0 F  S X=$O(^DD(F(Z),DJ(Z),1,F,"%D",X)) Q:X'>0  Q:+%&(X>+%)  S W=^(X,0) W:X>1 " " D W1^DIDH1 G ND:M=U
 W !
 Q
 ;
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
 Q
W F K=0:0 W:$D(DDF) ! W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y=""  S W=%Y,DDF=1
 K:'X DDF Q:$Y+6<IOSL
HD S DC=DC+1 D ^DIDH Q

DID2
DID2 ;SFISC/GFT-MODIFIED DD ;12/30/93  13:55 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $D(DINM) G DZ:X'["C"!(X["X")!'$D(^DD(F(Z),DJ(Z),9.1)) S %Y=X,X=^(9.1),W=" --  "_X D ^DIM,W1^DIDH1:'$D(X) S X=%Y G Q:M=U G DZ
 F I=9.2:.1 Q:'$D(^(I))#2  W ! S W=I_" = "_^(I) D W G Q:M=U
 I $D(^(9.1))#2 S W=^(9.1),%Y="9.1 = " S:X["C" %Y="ALGORITHM:  " W !,?DDL1,%Y D W S W=$P("  (ALWAYS "_$E(N,$L(N)-1)_" DECIMAL DIGITS)",U,N?.E1" S X=$J(X,0,"1N1")") D W G Q:M=U
DZ ;
 I $D(^("DT")) S Y=^("DT") D D^DIQ W !?DDL1,"LAST EDITED: " S W=Y D W1^DIDH1 G Q:M=U
H K W I $D(^DD(F(Z),DJ(Z),3)),^(3)]"" W !?DDL1,"HELP-PROMPT:" S W=^(3) D W1^DIDH1 G Q:M=U
 F %Y=21,23 I $O(^DD(F(Z),DJ(Z),%Y,0))>0 D DE^DIDH1 G:M=U Q
SC ;
 I $D(^DD(F(Z),DJ(Z),12.1)),'$D(DINM) I X["P"!(X["S") W !?DDL1,"SCREEN:" S W=^(12.1) D W I $D(^(12)) W !?DDL1,"EXPLANATION:" S W=^(12) D W G Q:M=U
 I '$D(DINM),$D(^DD(F(Z),DJ(Z),4)),^(4)]"" W !?DDL1,"EXECUTABLE HELP:" S W=^(4) D W G Q:M=U
 I $D(^(9.02))#2 W !?DDL1,"SUM:" S W=^(9.02) D W G Q:M=U
D I $D(^(8.5)) W !?DDL1,"DELETE AUTHORITY: " S W=^(8.5) D W G Q:M=U
 I X'["C",$D(^(9))#2,^(9)]"" W !?DDL1,"WRITE AUTHORITY:" S W=^(9) D W G Q:M=U
RD I $D(^(8))#2,^(8)]"" W !?DDL1,"READ AUTHORITY:" S W=^(8) D W G Q:M=U
 I $D(^(10))#2,^(10)]"" W !?DDL1,"SOURCE OF DATA:" S W=^(10) D W G Q:M=U
 I $O(^(11,0))>0 W !?DDL1,"DATA DESTINATION:" S I=0 F  S I=$O(^DD(F(Z),DJ(Z),11,I)) Q:I=""  S:$D(^DIC(.2,+^(I,0),0)) W=$P(^(0),U)
 I  S I=-1 D W G Q:M=U
 I $O(^DD(F(Z),DJ(Z),20,0))>0 W !?DDL1,"GROUP:" S I=0 F  S I=$O(^DD(F(Z),DJ(Z),20,I)) Q:I=""  S W=$P(^(I,0),U)
 I  S I=-1 D W
 Q
 ;
W F K=0:0 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y=""  S W=%Y W !
 I $Y+6>IOSL S DC=DC+1 D ^DIDH
 I $D(^DD(F(Z),DJ(Z),0))
 Q
 ;
Q G ND^DID1
 ;
MOD ;FROM DID
 S X=U,%=2 W !,"WANT THE LISTING TO INCLUDE MUMPS CODE" D YN^DICN Q:%<0  S:%=2 DINM=1 I '% W !?5,"Enter YES, to see the MUMPS code as in the STANDARD listing.",!?5,"Enter NO, to eliminate MUMPS code from the listing." G MOD
MOD2 S %=2 W !,"WANT TO RESTRICT LISTING TO CERTAIN GROUPS OF FIELDS" D YN^DICN S:%=2 X=0 Q:%<0!(%=2)  I '% W !?5,"Enter YES, to select the Groups you wish to see in this listing.",!?5,"Enter NO, to see all fields." G MOD2
 W ! S DP="",L=""","_$S(Y-2:"DJ(Z)",1:"D1")_"))"
G R "Include GROUP: ",X:DTIME S:'$T X=U,DTOUT=1 I X[""""!($L(X)>30)!(X'?.ANP) W $C(7),!,"SORRY, THAT ISN'T WHAT A 'GROUP' NAME CAN LOOK LIKE",! G G
 Q:X[U  I X'?."?" S C="!" S:X?1"'"1E.E X=$E(X,2,99),C="&'" S DP=DP_C_"$D(^DD(F(Z),""GR"","""_X_L W !,"And " G G
 I X="" S:DP]"" DIGR="I "_$E(DP,2,999) Q
 W !?5,"To list only those fields which have a particular 'GROUP'",!?5,"(or several 'GROUPS') associated with them, Enter the GROUP NAME",!
 W ?5,"To screen out a group, Type ""'"" in front of its name.",!
 G G

DIDC
DIDC ;SFISC/XAK-CONDENSED DD ;7/29/94  10:49
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DM="",DAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),X="I $Y+3>IOSL W $C(7) D P"
EN S N(0)=X1-.0000001,I=0 F  S N(0)=$O(^DD(N(0))) Q:N(0)'>0!(N(0)>X2)  S NAME=$O(^DD(N(0),0,"NM",0)) I NAME'="" S P=0 D P,P2 G:DM["^" EXIT
EXIT K %DT,%ZIS,DAT,I,J,K,K1,M,N,N1,NAME,MO,P,X,X1,X2,Y,KK,NF,NY,POP S D0="B",M=DM K DM Q
P S P=P+1 I IOST?1"C-".E R:P'=1 DM:DTIME Q:DM["^"!'$T
 W:$D(DIFF)&($Y) @IOF S DIFF=1 W !!,"CONDENSED DATA DICTIONARY---",NAME," FILE"," (#",N(0),")" I $D(^%ZOSF("UCI"))#2 X ^("UCI") W ?47,"UCI: "_Y
 W ?63,$S($G(^DD(N(0),0,"VR"))]"":"   VERSION: "_$P(^("VR"),U),1:" ") W !!,"STORED IN: ",$S($D(^DIC(N(0),0,"GL")):^("GL"),1:""),?58,DAT,?70,"PAGE ",P W ! F I=0:1:IOM-1 W "-"
 G P1:P'=1 W !!,?50,"FILE SECURITY"
 W !,?35,"DD SECURITY    : ",$S($D(^DIC(N(0),0,"DD")):^("DD"),1:""),?58,"DELETE SECURITY: ",$S($D(^("DEL")):^("DEL"),1:"")
 W !,?35,"READ SECURITY  : ",$S($D(^("RD")):^("RD"),1:""),?58,"LAYGO SECURITY : ",$S($D(^("LAYGO")):^("LAYGO"),1:"")
 W !,?35,"WRITE SECURITY : ",$S($D(^("WR")):^("WR"),1:"")
 W !,"CROSS REFERENCED BY:",!,?5
 S NY="" F KK=1:1 S NY=$O(^DD(N(0),0,"IX",NY)) Q:NY=""  S NF=+$O(^(NY,0)),N1=+$O(^(NF,0)) D
 .N % S %=0 F  S %=$O(^DD(NF,N1,1,%)) Q:'%  I $D(^(%,0)),+^(0)=N(0),$P(^(0),U,2)=NY W:$X>50&($L($P(^DD(NF,N1,0),"^",1)>20)) !,?5 W " ",$P(^DD(NF,N1,0),"^",1),"(",NY,") "
P1 W !!!,?33,"FILE STRUCTURE",!! W "FIELD",?10,"FIELD",!,"NUMBER",?10,"NAME",! Q
P2 S M(0)=0 F K1=0:0 S M(0)=$O(^DD(N(0),M(0))),K=0 Q:+M(0)'>0!(M(0)?1U.U)  X X Q:DM["^"  W !,M(0),?10,$P(^DD(N(0),M(0),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^"
 Q
MO X X Q:DM["^"  S N(K)=+$P(^DD(N(K-1),M(K-1),0),U,2) S M(K)=0
 F L=0:0 S M(K)=$O(^DD(N(K),M(K))) Q:M(K)'>0  X X Q:DM["^"  W !,?10+((K-1)*5),M(K),?15+((K-1)*5),$P(^DD(N(K),M(K),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^"
 Q:DM["^"  X X Q:DM["^"  S K=K-1 Q
M S J=$P(^(0),U,2) W $S(+J:"(Multiple-"_+J,1:"("_J),"), [",$P(^(0),U,4),"]"
 Q
PTR ;
 S F=0,I=0 F  S F=$O(^UTILITY($J,"P",F)) Q:F=""  D PT
 S F=-1 Q
PT W !,F_" " W:$X>24 !?19 W "(#"_^(F,0)_") "
 S %=0 F  S %=$O(^UTILITY($J,"P",F,%)) Q:%=""  W ?33," ",$S(%=F(1):"",1:$P(^DD(%,0)," SUB-FIELD",1)_":") S S=0 F  S S=$O(^UTILITY($J,"P",F,%,S)) Q:S=""  W ?34,$P(^DD(%,S,0),U)," (#"_S_")",!
 S (%,S)=-1 Q
 ;
L ; CUSTOM LOOP
 I $G(Y)=U!($G(M)=U) G Q
 I DJ,IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T G Q
 K ^UTILITY($J,0)
 S DIB=$O(^DIC(+DIB)) G:DIB>DIB(1)!(+DIB'=DIB) Q
 I $G(DIPP(0,"IX"))["^DD(DFF,""AUDIT""",$O(^DD(DIB,"AUDIT",""))="" D  G:'DIB!(DIB>DIB(1)) Q
 . F  S DIB=$O(^DIC(+DIB)) Q:'DIB!(DIB>DIB(1))  Q:$O(^DD(DIB,"AUDIT",""))]""
 S %X="DIPP(",%Y="DPP(" D %XY^%RCR S DPP=DIPP,L=0
 S DFF=DIB,DJ=DIJS,DPQ=DIPQ,M=DIMS S:'$D(DIA) DC="," G ^DIO
Q S DFF=DIB(1) G STOP^DIO4

DIDG
DIDG ;SFISC/RWF-GLOBAL MAP ;08:03 AM  11 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K W S DJ(Z)=D0,F=0,W=F(Z),M=1,DP=0
 W !
UP I $D(^DD(W,0,"UP")) S Y=^("UP"),N=$O(^DD(Y,"SB",W,0)) I $D(^DD(Y,N,0)) S F=F+1,W(F)=$P($P(^(0),U,4),";",1),W=Y G UP
 S W=$S($D(^DIC(W,0,"GL")):^("GL"),1:"^("),Y=0 F N=F:-1:1 S W=W_"D"_Y_","_$S(+W(N)=W(N):W(N),1:""""_W(N)_"""")_",",Y=Y+1
 S DID(Z-1)=W K W
 ;
L S DN(Z)=""
A S DN(Z)=$O(^DD(F(Z),"GL",DN(Z))),DP(0)=0 I DN(Z)="" D POP Q
 S DID(Z)=DID(Z-1)_"D"_(F+Z-1)_","_DN(Z) I $O(^DD(F(Z),"GL",DN(Z),""))'=0 S W=DID(Z)_")=" W ! D WL Q:M=U
B S DP=$O(^DD(F(Z),"GL",DN(Z),DP)) G PUSH:DP=0,A:DP=""
 S DF=$O(^DD(F(Z),"GL",DN(Z),DP,0))
 I DP(0)+1<DP F I1=DP(0)+1:1:DP-1 S W=" ^ " D WL Q:M=U
 S N=^DD(F(Z),DF,0),DP(0)=DP
 S X=$P(N,U,2) I +X S Z=Z+1,F(Z)=+X D L G B
 S W="(#"_DF_") "_$P(N,U,1)_" ["_DP
 F Y="F","S","D","N","P","W","V","K" I X[Y S W=W_Y
 S W=W_"] ^ " D WL Q:M=U  G B
 ;
PUSH S N=$O(^DD(F(Z),"GL",DN(Z),DP,0)) S:N="" N=-1 S Y=^DD(F(Z),N,0),DID(Z)=DID(Z)_","
 W !,DID(Z)_"0)=^"_$P(Y,U,2)_"^^  (#",N,") "_$P(Y,U,1) S Z=Z+1,F(Z)=+$P(Y,U,2)
 D L Q:M=U  G A
 ;
POP S Z=Z-1,DID(Z)=$E(DID(Z),1,$L(DID(Z))-1) Q:Z  K DN,W,DP,DG,DID S DN=0 W ! Q
 ;
END ;
 S S=0,M=1
T1 S S=S+1 D:$Y+3>IOSL HDR Q:M=U
 W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
 S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
 F  S DA=$O(@DFF@("F"_F(1),DA)) Q:DA=""  D  Q:M=U
 . S DUB=0 F  S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:DUB'>0  D  Q:M=U
 .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
 K %1 Q:M=U  G T1:S<4
Q Q
TEMPL I $Y+3>IOSL D HDR Q:M=U
 N % S %=$S($D(^("ROU")):"Compiled: "_^("ROU"),'$D(^("ROU"))&($D(^("ROUOLD"))):"Previously Compiled: "_^("ROUOLD"),1:"")
 I %]"",DFF["DIBT" S %=%_"*"
 I DFF'["DIST" W !,DFF,"("_DUB_")= ",$P(%1,U)_"    "_%
 E  D FORM
 Q
WL I $Y+4>IOSL S %1=W D HD Q:M=U  S W=%1 I W[DID(Z) S W=""
 F I=1:1 S Y=$P(W," ",I)_" " Q:$P(W," ",I,99)=""  W:$X+$L(Y)+2>IOM !,?$L(DID(Z)),"==>" W Y
 Q
W W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S Q:%Y=""  S W=%Y G W
 ;
HD S DC=DC+1 D ^DIDH Q:M=U  W !,DID(Z),")= " Q
 ;
HDR ;
 S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U
H1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "TEMPLATE LIST  --  FILE #"_DIB,?(IOM-20),$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_"    PAGE "_DC
 S M="",$P(M,"-",IOM)="" W !,M
 Q
 ;
FORM ;
 W !,"^DIST(.403,"_DUB_")= ",$P(%1,U)_"    "_%
 ;
 N B,L,P
 S L=1,L(1)=U
 S P=0 F  S P=$O(^DIST(.403,DUB,40,P)) Q:'P  D  Q:M=U
 . Q:$D(^DIST(.403,DUB,40,P,0))[0  S B=$P(^(0),U,2) D:B BLOCK  Q:M=U
 . S B=0 F  S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B  D BLOCK  Q:M=U
 W !
 Q
BLOCK ;
 N I
 F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
 S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
 Q:$D(^DIST(.404,B,0))[0  S %1=^(0)
 ;
 I $Y+3>IOSL D HDR Q:M=U
 W !?2,"^DIST(.404,"_B_")= ",$P(%1,U)
BLOCKQ Q

DIDH
DIDH ;SFISC/XAK-HDR FOR DD LISTS ;2/18/93  16:21 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D ^DIDH1
Q K DDV,%F,M1 Q
 ;
XR S X=2,J=0,DG=F(Z) W:$Y !
XL S J=$O(^DD(DA,0,"IX",J)) I J="" S F(Z)=DG Q
 F K=0:0 S K=$O(^DD(DA,0,"IX",J,K)) G XL:K'>0 F N=0:0 S N=$O(^DD(DA,0,"IX",J,K,N)) Q:N'>0  I 1 S F(Z)=K,DJ(Z)=N X:$D(DIGR) DIGR D:$T XL1
XL1 F %=0:0 S %=$O(^DD(K,N,1,%)) Q:'%!(M=U)  I $D(^(%,0)),+^(0)=DA,$P(^(0),U,2)=J W:X=2 !,"CROSS",! W $P(", ^REFERENCED BY: ",U,X) S X=$P(^DD(K,N,0),U)_"("_J_")" W:($L(X)+$X+4)'<IOM !?15 W X S X=1 Q:$Y+4'>IOSL  I '$D(DIU) D H S X=2
 Q
POINT ; CALLED BY ^DD(1,.01,"DEL",.5,0)
 S W1="W:$Y ! W !,""POINTED TO BY: "",?15" I $O(^DD(DA,0,"PT",""))'="" S DDPT=1
 S X="" F  S X=$O(^DD(DA,0,"PT",X)) Q:X=""  S DG=0 F  S DG=$O(^DD(DA,0,"PT",X,DG)) Q:DG=""  D PD W:$D(^DD(DA,0,"PT",X,DG)) !?15 I '$D(DIU) D H G Q:M=U
 S (DG,X)=-1 K W1,DDPT Q
PD I $S('$D(^DD(X,DG,0)):1,$P(^(0),U,2)["V":0,1:$P($P(^(0),U,2),"P",2)-DA) K ^DD(DA,0,"PT",X,DG) Q
 S %=X,%F=DG
WR I '$D(IOM) S IOP="HOME" N %X D ^%ZIS Q:POP
 I $D(DDPT) X W1 K DDPT
 S X1=$P(^DD(%,%F,0),U)_" field (#"_%F_")"
UP I $L(X1)+$L(%)+$L($O(^DD(%,0,"NM",0)))>225 S X1=X1_" etc... ^" G L1
 S X1=X1_" of the "_$O(^(0))
 I $D(^DD(%,0,"UP")) S X1=X1_" sub-field (#"_%_")",%=^("UP") G UP
 S X1=X1_" File (#"_%_") ^"
L1 F DDC=1:1 S DDV=$P(X1," ",DDC)_" " Q:DDV["^"  W:$L(DDV)+$X>IOM !,?19 W DDV
 K DDC,DDV,X1 Q
 ;
TRIG ;CALLED BY ^DD(1,.01,"DEL","TRB",0)
 S W1="W:$Y ! W !,""A FIELD IS"",!,""TRIGGERED BY :"",?15",DDPT=1
 K X S X="" F  S X=$O(^DD(DA,"TRB",X)) Q:X=""  I X-DA,'$D(^DD(DA,"SB",X)) S %=0 F  S %=$O(^DD(DA,"TRB",X,%)) Q:%=""  S %X=0 F  S %X=$O(^DD(DA,"TRB",X,%,%X)) Q:%X=""  S %Y=0 F  S %Y=$O(^DD(DA,"TRB",X,%,%X,%Y)) Q:%Y'>0  D TT
 S %Y=-1 I $D(X)>9 S %X=0 F  S %X=$O(X(%X)) Q:%X=""  S X=0 F  S X=$O(X(%X,X)) Q:X=""  S %F=X,%=%X D WR:$D(^DD(%,X,0)) W !?15 D:'$D(DIU) H I 1
 K X,%X,%Y,W1,DDPT Q
 ;
TT S X(X,%)=0 I $D(^DD(X,%,0)) Q:$P(^(0),U,2)  I $D(^(1,%X,0)),^(0)["TRIGGER" Q
 K X(X,%),^DD(DA,"TRB",X,%,%X,%Y)
 Q
H I $D(IOSL),$Y+4>IOSL S DC=DC+1 D ^DIDH1 G Q:M=U
 Q
W F K=0:1 W:$D(DDF) !?25 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y=""  S W=%Y,DDF=1
 K DDF Q

DIDH1
DIDH1 ;SFISC/XAK-HDR FOR DD LISTS ;12/16/94  14:13
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S M=1 I DC=1 S (F(1),DA)=DFF,Z=1
 E  I $Y,IOST?1"C".E W $C(7) R M:DTIME I M=U!'$T K DIOEND S M=U,DN=0 Q
 S M1=$S($G(^DD(F(1),0,"VR"))]"":" (VERSION "_$P(^("VR"),U)_")   ",1:"") I IOST?1"C".E S DIFF=1
 W:$D(DIFF)&($Y) @IOF S DIFF=1 W $S(DHIT["DIDX":"BRIEF",DHIT["DIDG":"GLOBAL MAP",$D(DINM):"MODIFIED",1:"STANDARD")
 W " DATA DICTIONARY #"_DFF_" -- "_$O(^DD(DFF,0,"NM",0))_" "_$P("SUB-",U,$D(^DD(DFF,0,"UP")))_"FILE   "
 S DIC=^DIC(DUB,0,"GL"),W=$E(DT,4,5)_"/"_(DT#100)_"/"_$E(DT,2,3)_"  PAGE "_DC W ?(IOM-$L(W)-1),W
 S M=IOM\2,S=" ",W="" I $D(^DD("SITE")) S W="SITE: "_^("SITE")_"   "
 I $D(^%ZOSF("UCI"))#2 X ^("UCI") S W=W_"UCI: "_Y
 W ! I DHIT["DIDX" W W,?(IOM-$L(M1)-1),M1 S W="",$P(W,"-",IOM)="" W !,W S W="" G Q^DIDH
 W "STORED IN ",DIC I $O(@(DIC_"0)"))'>0 W "  *** NO DATA STORED YET ***"
 E  S I=$P(^(0),U,4) W:I "  ("_I_" ENTR"_$S(I=1:"Y)",1:"IES)")
 W "   ",W,?(IOM-$L(M1)-1),M1 G G:DHIT["DIDG"
 W !!,"DATA",?14,"NAME",?36,"GLOBAL",?50,"DATA",!,"ELEMENT",?14,"TITLE",?36,"LOCATION",?50,"TYPE"
G W ! F I=1:1:IOM-1 W "-"
 S W="" Q:DC>1
 S DG=Z,DIWF="W|",DIWL=1,DIWR=IOM D
 .N A,D,X S A=$P($G(^DIC(DA,"%D",0)),U,3) F D=0:0 S D=$O(^DIC(DA,"%D",D)) Q:D'>0  Q:+A&(D>A)  S X=^(D,0) D ^DIWP I $D(DN),'DN S M=U Q
 D ^DIWW S Z=DG Q:'DN  I DHIT["DIDG" D XR^DIDH Q
 Q:DHIT["DIDX"!(M=U)  W !
 F %=1:1:4 S X=$P("SCR^DIC^ACT^DIK",U,%) I $D(^DD(DA,0,X)),^(X)]"" W !,$P("FILE SCREEN (SCR-node) ^SPECIAL LOOKUP ROUTINE ^POST-SELECTION ACTION  ^COMPILED CROSS-REFERENCE ROUTINE",U,%)_": " S W=^(X) D W^DIDH G Q:M=U
 W:$P($G(^DD(DA,0,"DI")),U)["Y" !,"THIS IS AN ARCHIVE FILE."
 W:$P($G(^DD(DA,0,"DI")),U,2)["Y" !,"EDITING OF FILE IS NOT ALLOWED."
 F N="DD","RD","WR","DEL","LAYGO","AUDIT" I $D(^DIC(DA,0,N)) W !?(Z+Z+14-$L(N)),N," ACCESS: ",^(N)
 W ! I $O(^DD(DA,0,"ID",""))]"" W !,"IDENTIFIED BY: "
 S X=0 F  S X=$O(^DD(DA,0,"ID",X)) Q:X=""  Q:'$D(^DD(DA,X,0))  S I1=$P(^(0),U)_" (#"_X_")" W:($L(I1)+$X)+1>IOM ! W ?15,I1 I $O(^DD(DA,0,"ID",X)) W ","
 S:X="" X=-1 D POINT^DIDH Q:M=U  D TRIG^DIDH,XR^DIDH Q:M=U  W !
 I $D(^DIC(DA,"%A")) S N=^("%A"),Y=$P(N,U,2) I Y X ^DD("DD") W !!?3,"CREATED ON: "_Y I $S($D(^DIC(200,0)):1,1:$D(^DIC(3,0))),^(0)["NEW PERSON"!(^(0)["USER")!(^(0)["EMPLOY"),$D(^(+N,0)) W " by "_$P(^(0),U)
Q Q
W W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S Q:%Y=""  S W=%Y G W
 Q
WR ;
 S W="TRIGGERED by the "_$P(^(0),U,1)_" field"
UP1 S W=W_" of the "_$O(^DD(%,0,"NM",0))
 I $D(^DD(%,0,"UP")) S %=^("UP") S W=W_" sub-field" G UP1
 S W=W_" File"
W1 S DDV1="" W ?DDL2 F K=1:1 S DDV=$P(W," ",K)_" ",DDV1=DDV1_DDV W:$L(DDV)+$X>IOM !?DDL2 W DDV Q:$L(DDV1)>$L(W)
 I $Y+6>IOSL S DC=DC+1 D DIDH1
 K DDV,DDV1 Q
DE ;
 N X K ^UTILITY($J,"W") S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIGG=Z
 W !?DDL1,$P("DESCRIPTION:^TECHNICAL DESCR:",U,%Y=23+1) D
 .N A1,D S A1=$P($G(^DD(F(DIGG),DJ(DIGG),%Y,0)),U,3) F D=0:0 S D=$O(^DD(F(DIGG),DJ(DIGG),%Y,D)) Q:D'>0  Q:+A1&(D>A1)  S X=^(D,0) D ^DIWP I $D(DN),'DN S M=U Q
 D ^DIWW I $D(DN),'DN S M=U K DIOEND
 S Z=DIGG K DIGG,DIWF,DIWL,DIWR
 Q

DIDT
DIDT ;SFISC/XAK-DATE/TIME UTILITY ;1:11 PM  16 Apr 1996
 ;;21.0;VA FileMan;**18**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
%DT ;
 I $G(DUZ("LANG"))>1,($G(^DI(.85,DUZ("LANG"),20.2))]"") X ^(20.2) Q
CONT ;
 K % S:$D(%DT)[0 %DT="" S:$G(DIQUIET)!($D(DDS)#2)!($D(ZTQUEUED)) %DT=$P(%DT,"E")_$P(%DT,"E",2) G NA:%DT'["A"
 W !,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B")_"//",1:"")
 R X:$S($D(DTIME):DTIME,1:300) S:'$T X="^",DTOUT=1
 I $D(%DT("B")),X="" S X=%DT("B")
 I "^"[X S Y=-1 K %I,% Q
NA S %(0)=X G 1:X'?.ANP
 F %=1:1:$L(X) Q:X?.UNP  S Y=$E(X,%) I Y?1L S X=$E(X,1,%-1)_$C($A(Y)-32)_$E(X,%+1,99)
 I %DT["E",X?."?" D HELP^%DTC G B
 I %DT["N",X?.N,+X=X G NO
 I X?1.A,(X["MID"!(X["NOON")) S X="@"_X
 I X'?1"NOV".E,X?1"N".1"OW".1P.E G N^%DTC:%DT["T"!(%DT["R") S X=$E(X,2,99),X="T"_$P(X,"OW")_$P(X,"OW",2)
 I X?1.N." "1.2A!(X?1.N1":"2N." ".2A)!(X?1.N1":"2N1":"2N." ".2A) S X="T@"_X
 I X?7N1"."1.N G R
 I X'["@",%DT'["R" G R
 I %DT'["T",%DT'["R" G NO
 S Y=$P(X,"@",2,9),X=$P(X,"@")
 F %=2,3 S %I=$P(Y,":",%) I %I,%I'?2N.PA G 1
 S:X="" X="T" S Y=$P(Y,":")_$P(Y,":",2)_$P(Y,":",3,9),%I=Y
 I Y?1.A S Y=$S(Y["MID":2400,Y["NOON":1200,1:"")
 G G:Y?4N,G1:Y?6N&(%DT["S"),1:Y'?1.N." ".1(1"AM",1"A",1"A.M",1"PM",1"P",1"P.M").P I %DT["R",Y="" G NO
 I %DT["S",Y?5.6N.A S %I=$P(Y,+Y,2),Y=$S(%I]"":$P(Y,%I),1:+Y),%(3)=$E(Y,$L(Y)-1,$L(Y)),Y=$E(Y,1,$L(Y)-2)_$S(%I["A":"A",%I["P":"P",1:"") G 1:%(3)>59,G:Y?4N
 S:Y<13 Y=Y*100 I %I["A" S Y=$S(Y=1200:2400,Y>1159:Y-1200,1:Y)
 E  I Y<1200,%I["P"!(Y<600) G 1:Y<100 S Y=Y+1200
G G 1:Y>2400,1:Y#100>59,1:('Y&('$G(%(3)))) S %(1)=$S('Y:".0000",1:Y/10000) G R
G1 G 1:Y>240000!'Y,1:$E(Y,3,4)#100>59,1:$E(Y,5,6)#100>59 S %(1)=Y/1000000
R I %DT["F"!(%DT["P") D TY S %(9)=%
7 G 8:X'?7N1".".E&(X'?7N) S Y=$E(X,8,16),%=$E(Y_"000000",2,7)
 G NO:%DT'["T"&Y
 I %DT["E",(%'?.N)!(%>240000)!($E(%,3,4)>59)!($E(%,5,6)>59) G NO
 S:Y %(1)=+Y S X=$E(X,4,7)_($E(X,1,3)+1700)
 I %DT["I" S X=$E(X,3,4)_$E(X,1,2)_$E(X,5,9)
8 S %I=0,%="" I X'?.N G T^%DTC:"T+-"[$E(X),U:X["^",1:$E(X)?1P,X
 I %DT'["X",X\300=6!(X?2N) S (%I(1),%I(2))=0,%I(3)=X G 3
 F %I=0:1 S Y=$E(X,1,2),X=$E(X,3,9) G OT:Y="",1:%DT["X"&'Y S:%I=2 Y=Y_X,X="" S %I(%I+1)=Y
 ;
X S Y=$E(X),X=$E(X,2,99) I Y?1N G A:%?.N,Y
 I Y?1A G A:%?.A,Y
OT D:%]"" % G 1:%I>3,X:Y?1P,1:Y]"",@%I
Y D % S %=Y G 1:%I>3,X
A S %=%_Y G X
TY S %=$H#1461,%=$H\1461*4+(%\365)+141-(%=1460) Q
0 ;
1 W:%DT["E"&'$D(DIER) $C(7),$S('$D(DDS):" ??",1:"")
B G %DT:%DT["A",NO
U S X="^",%(0)=X
NO S Y=-1 G Q:%DT'["A",Q:X["^" W $C(7)," ??" G %DT
2 I %I(2)>31,%DT'["X" S %I(3)=%I(2),%I(2)=0 G 1:'%I(2)&$G(%(1)) G 3
 D TY S %I(3)=% D PF^%DTC:$D(%(9)) G C
3 I %I(3)?2N D  G C
 . I '$D(%(9)) D TY S %(9)=%
 . N A S A=$E(%(9))*100
 . I $E(%(9),2,3)=%I(3) S %I(3)=A+%I(3) Q
 . I %DT["P" S %I(3)=$S(%I(3)<$E(%(9),2,3):A,1:A-100)+%I(3) Q
 . I %DT["F" S %I(3)=$S(%I(3)>$E(%(9),2,3):A,1:A+100)+%I(3) Q
 . S %I(3)=A+%I(3) Q
 S %I(3)=%I(3)-1700 G 1:%I(3)'?3N
C I %DT["I",%I(2)>0 S %=%I(2),%I(2)=%I(1),%I(1)=%
 I %I(1)>12 G 1
 I %I(2)>28,$E("303232332323",%I(1))+28<%I(2),%I(1)-2!(%I(2)-29)!(%I(3)#4)!(%I(3)=200) G 1
D D P
E I $D(%(1)) S:$D(%(3)) %(1)=$E(%(1)_"000",1,5)_%(3) S Y=+(Y_%(1))
 I %DT["E" S %=Y D DD W "  ("_Y_")" S Y=%
 I $D(%DT(0)) S %=%DT(0),%I=$S(%["-":Y,1:-Y) D:'% Z I $S(%DT["S":%,1:%\.0001/10000)+%I>0 G 1
Q S X=%(0) K %,%I,%H Q
Z I $P("NOW",%(0))="" S %=Y
 E  D NOW^%DTC
 S:%DT(0)["-" %=-% Q
DD I $G(DUZ("LANG"))>1 S Y=$$OUT^DIALOGU(Y,"DD") Q
 Q:'Y  S Y=$S($E(Y,4,5):$P($T(M)," ",$E(Y,4,5)+2)_" ",1:"")_$S($E(Y,6,7):$E(Y,6,7)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":"."_$P(Y,".",2),1:"")
 I Y["." S Y=$P(Y,".")_"@"_$E(Y_0,14,15)_":"_$E(Y_"000",16,17)_$S($E(Y,18,19):":"_$E(Y_0,18,19),1:"")
 I $D(%DT)#2,%DT["S",Y["@",$P(Y,":",3)="" S Y=Y_":00"
 Q
P S Y=%I(3)_$E(%I(1)+100,2,3)_$E(%I(2)+100,2,3) Q
% I %DT["I",%?3.A S %I=9 Q
 I %?3.A S %=$F($T(M),$E(%,1,3))-4\4 I %>0,%I=1 S %I(1)=%,%=+%(0)
 S:(%<1&(%I+1'=3)) %I=9 S %I=%I+1,%I(%I)=%,%=""
M ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC

DIDTC
DIDTC ;SFISC/XAK-DATE/TIME OPERATIONS ;9/24/96  15:35
 ;;21.0;VA FileMan;**18**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
D I 'X1!'X2 S X="" Q
 S X=X1 D H S X1=%H,X=X2,X2=%Y+1 D H S X=X1-%H,%Y=%Y+1&X2
 K %H,X1,X2 Q
 ;
C S X=X1 Q:'X  D H S %H=%H+X2 D YMD S:$P(X1,".",2) X=X_"."_$P(X1,".",2) K X1,X2 Q
S S %=%#60/100+(%#3600\60)/100+(%\3600)/100 Q
 ;
H I X<1410000 S %H=0,%Y=-1 Q
 S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7)
 S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14)
TOH S %H=%M>2&'(%Y#4)+$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D
 S %='%M!'%D,%Y=%Y-141,%H=%H+(%Y*365)+(%Y\4)-(%Y>59)+%,%Y=$S(%:-1,1:%H+4#7)
 K %M,%D,% Q
 ;
DOW D H S Y=%Y K %H,%Y Q
DW D H S Y=%Y,X=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY"
 S:Y<0 X="" Q
7 S %=%H>21608+%H-.1,%Y=%\365.25+141,%=%#365.25\1
 S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
 S X=%Y_"00"+%M_"00"+%D Q
 ;
YX D YMD S Y=X_% G DD^%DT
YMD D 7 S %=$P(%H,",",2) D S K %D,%M,%Y Q
T F %=1:1 S Y=$E(X,%) Q:"+-"[Y  G 1^%DT:$E("TODAY",%)'=Y
 S X=$E(X,%+1,99) G PM:Y="" I +X'=X D DMW S X=%
 G:'X 1^%DT
PM S @("%H=$H"_Y_X) D TT G 1^%DT:%I(3)'?3N,D^%DT
N F %=2:1 S Y=$E(X,%) Q:"+-"[Y  G 1^%DT:$E("NOW",%)'=Y
 I Y="" S %H=$H D %H G RT
 S X=$E(X,%+1,99)
 I X?1.N1"H" S X=X*3600,%H=$H,@("X=$P(%H,"","",2)"_Y_X),%=$S(X<0:-1,1:0)+(X\86400),X=X#86400,%H=$P(%H,",")+%_","_X G RT
 D DMW G 1^%DT:'% S @("%H=$H"_Y_%),%H=%H_","_$P($H,",",2) D %H
RT D TT S %=$P(%H,",",2) D S S %=X_$S(%:%,1:.24) I %DT'["S" S %=+$E(%,1,12)
 Q:'$D(%(0))  S Y=% G E^%DT
PF S %H=$H D YMD S %(9)=X,X=%DT["F"*2-1 I @("%I(1)*100+%I(2)"_$E("> <",X+2)_"$E(%(9),4,7)") S %I(3)=%I(3)+X
 Q
TT D 7 S %I(1)=%M,%I(2)=%D,%I(3)=%Y K %M,%D,%Y Q
NOW S %H=$H,%H=$S($P(%H,",",2):%H,1:%H-1)
 D TT S %=$P(%H,",",2) D S S %=X_$S(%:%,1:.24) Q
DMW S %=$S(X?1.N1"D":+X,X?1.N1"W":X*7,X?1.N1"M":X*30,+X=X:X,1:0)
 Q
%H I '$P(%H,",",2) S %H=%H-1 Q
 I $P(%H,",",2)<60&(%DT'["S") S $P(%H,",",2)=60
 Q
COMMA ;
 S %D=X<0 S:%D X=-X S %=$S($D(X2):+X2,1:2),X=$J(X,1,%),%=$L(X)-3-$E(23456789,%),%L=$S($D(X3):X3,1:12)
 F %=%:-3 Q:$E(X,%)=""  S X=$E(X,1,%)_","_$E(X,%+1,99)
 S:$D(X2) X=$E("$",X2["$")_X S X=$J($E("(",%D)_X_$E(" )",%D+1),%L) K %,%D,%L
 Q
HELP S DDH=$S($D(DDH):DDH,1:0),A1="Examples of Valid Dates:" D %
 S A1="  "_$S(%DT["I":"20.1.1957",1:"JAN 20 1957 or 20 JAN 57")_" or "_$S(%DT["I":"20/1",1:"1/20")_"/57"_$S(%DT'["N":" or "_$S(%DT["I":200157,1:"012057"),1:"") D %
 S A1="  T   (for TODAY),  T+1 (for TOMORROW),  T+2,  T+7,  etc." D %
 S A1="  T-1 (for YESTERDAY),  T-3W (for 3 WEEKS AGO), etc." D %
 S A1="If the year is omitted, the computer "_$S(%DT["P":"assumes a date in the PAST.",%DT["F":"assumes a date in the FUTURE.",1:"uses the CURRENT YEAR.") D %
 I %DT'["X" S A1="You may omit the precise day, as:  "_$S(%DT["I":1,1:"JAN,")_" 1957" D %
 I %DT'["T",%DT'["R" G 0
 S A1="If only the time is entered, the current date is assumed." D %
 S A1="Follow the date with a time, such as "_$S(%DT["I":"20.1",1:"JAN 20")_"@10, T@10AM, 10:30, etc." D %
 S A1="You may enter a time, such as NOON, MIDNIGHT or NOW." D %
 I %DT["S" S A1="Seconds may be entered as 10:30:30 or 103030AM." D %
 I %DT["R" S A1="Time is REQUIRED in this response." D %
0 Q:'$D(%DT(0))
 S A1=" " D % S A1="Enter a date which is "_$S(%DT(0)["-":"less",1:"greater")_" than or equal to " D %
 S Y=$S(%DT(0)["-":$P(%DT(0),"-",2),1:%DT(0)) D DD^%DT:Y'["NOW"
 I '$D(DDS) W Y,"." K A1 Q
 S DDH(DDH,"T")=DDH(DDH,"T")_Y_"." K A1 Q
 ;
% I '$D(DDS) W !,"     ",A1 Q
 S DDH=DDH+1,DDH(DDH,"T")="     "_A1 Q

DIDU
DIDU ;SEA/TOAD-VA FileMan: DD Tools, Format ;5/8/96  16:06
 ;;21.0;VA FileMan;**6,17,8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12021;6142297;4690;
 
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) 
XTRNLX ; Branch from DILFD or DIQGU
 ; ENTRY POINT--convert DINTERNL to external format
 ; func, all passed by value
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DICLERR S DICLERR=$G(DIERR) K DIERR
INPUT 
 I $G(DINTERNL)="" Q ""
 S DIMSGA=$G(DIMSGA)
 S DIFILE=$G(DIFILE)
 I DIFILE'>0 D ERR(DIMSGA,202,"","","","FILE") Q ""
 S DIFLAGS=$G(DIFLAGS)
 I DIFLAGS'?.1(1"F",1"L",1"U") D ERR(DIMSGA,301,"","","",DIFLAGS) Q ""
 S DIFIELD=$G(DIFIELD)
 I DIFIELD'>0 D ERR(DIMSGA,202,"","","","FIELD") Q ""
PREP 
 N DICHAIN,DIDONE,DIEN,DIEXTRNL
 N DIHEAD,DINEXT,DINODE,DIOUT,DIROOT,DITYPE,DIXFORM
 S DICHAIN=0,DIDONE=0,DIEN="",DIEXTRNL=""
 S DIHEAD="",DINEXT="",DIOUT=0,DIXFORM=""
 N DIPREV S DIPREV=""
 N DIPREVF S DIPREVF=""
 I '$D(^DD(DIFILE)) D ERR(DIMSGA,401,DIFILE) Q ""
 S DINODE=$G(^DD(DIFILE,DIFIELD,0))
 I DINODE="" D ERR(DIMSGA,501,DIFILE,"",DIFIELD,DIFIELD) Q ""
 S DITYPE=$P(DINODE,U,2)
RESOLVE 
 F  D  I DIDONE!$G(DIERR)!DIOUT Q
XFORM .
 . I DIFLAGS["U",DIXFORM'="",DITYPE'["P",DITYPE'["V" S DITYPE=DITYPE_"O"
 . I DITYPE["O" D  I DIDONE!$G(DIERR) Q
 . . I DIFLAGS["F",DICHAIN Q
 . . I DIFLAGS["L",DITYPE["P"!(DITYPE["V") Q
 . . I DIXFORM=""!(DIFLAGS'["U") S DIXFORM=$G(^DD(DIFILE,DIFIELD,2))
 . . I DIXFORM="" Q
 . . I DIFLAGS["U",DITYPE["P"!(DITYPE["V") Q
 . . N Y S Y=DINTERNL
 . . X DIXFORM
 . . I $G(DIERR) D ERR^DICF6(120,DIFILE,DIEN,"","Output Transform") Q
 . . S DIEXTRNL=Y
 . . S DIDONE=1
CHAIN .
 . I DITYPE S DIOUT=1 Q
 . I DITYPE'["P",DITYPE'["V" S DIOUT=1 Q
 . I 'DINTERNL D  Q
 . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"pointer") Q
 . . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"pointer")
 . I DITYPE["P" S DIROOT=$P(DINODE,U,3),DINEXT=+$P($P(DINODE,U,2),"P",2)
 . I DITYPE["V" S DIROOT=$P(DINTERNL,";",2),DINEXT=""
10 . S DIHEAD=$G(@(U_DIROOT_"0)")) ;***** Naked Set *****
 . I DIHEAD="" D  Q
 . . D HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT)
 . I DITYPE["V" S DINEXT=+$P(DIHEAD,U,2) I 'DINEXT D  Q
 . . D ERR(DIMSGA,404,"","","",$$CREF^DILF(U_DIROOT))
 . I '$D(^(+DINTERNL)) D  Q  ;***** Naked *****
 . . N DI S DI="pointer to File #"
 . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,DI_DINEXT) Q
 . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,DI_DINEXT)
20 . S DIEN=+DINTERNL
 . S DIPREV=DIFILE,DIFILE=DINEXT
 . S DINTERNL=$P($G(^(DIEN,0)),U) ;***** Naked *****
 . I DINTERNL="" D ERR(DIMSGA,603,DIFILE,"",.01,DIEN) Q
 . S DINODE=$G(^DD(DIFILE,.01,0))
 . S DITYPE=$P(DINODE,U,2)
30 . I DITYPE="" D ERR(DIMSGA,510,DIFILE,"",.01) Q
 . S DIPREVF=DIFIELD,DIFIELD=.01
 . S DICHAIN=1
 I DIDONE Q DIEXTRNL
BAD 
 I $G(DIERR) Q ""
 I DITYPE["C" D ERRPTR("Computed") Q ""
 I DITYPE["W" D ERRPTR("Word Processing") Q ""
 I DITYPE S DITYPE=$P($G(^DD(+DITYPE,.01,0)),U,2) D  Q ""
 . I DITYPE["W" D ERRPTR("Word Processing") Q
 . D ERRPTR("Multiple") Q
CODES 
 I DITYPE["S" D  Q DIEXTRNL
 . N DICODES S DICODES=";"_$P(DINODE,U,3)
 . N DISTART S DISTART=$F(DICODES,";"_DINTERNL_":")
 . I 'DISTART S DIEXTRNL="" D  Q
 . . I 'DICHAIN D ERR(DIMSGA,730,DIFILE,"",DIFIELD,DINTERNL,"code") Q
 . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,"code")
 . S DIEXTRNL=$P($E(DICODES,DISTART,$L(DICODES)),";")
OTHER 
 I DITYPE["D",DINTERNL D  Q DIEXTRNL
 . S DIEXTRNL=$$FMTE^DILIBF(DINTERNL,"1U")
 . I DIEXTRNL'="" Q
 . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"date") Q
 . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"date")
 I DICLERR'=""!$G(DIERR) D
 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 Q DINTERNL
 
HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT) 
 ; CHAIN--pick a header error and log it
 ; proc, all by val
 I DITYPE["P" D  Q
 . I 'DINEXT!'$D(^DD(DINEXT)) D ERR(DIMSGA,537,DIFILE,"",DIFIELD) Q
 . D ERR(DIMSGA,403,DINEXT)
 ; otherwise, it's a variable pointer
 I DICHAIN D ERR(DIMSGA,648,DIFILE,"",DIFIELD,DIEN,DINTERNL) Q
 D ERR(DIMSGA,348,"","","",DINTERNL)
 Q
 
ERR(DIMSGA,DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) 
 ; error logging procedure
 N DIPE
 N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
 D BLD^DIALOG(DIERN,.DIPE,.DIPE,DIMSGA,"F")
 S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
 Q
 
ERRPTR(DITYPE) 
 ; error logging shell for errors 520 & 537
 I DICHAIN D ERR(DIMSGA,537,DIPREV,"",DIPREVF) Q
 D ERR(DIMSGA,520,DIFILE,"",DIFIELD,DITYPE)
 Q

DIDU1
DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;7/17/94  17:28 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
IEN(DIENS,DIFLAGS) ;
 ;ENTRY POINT--return whether the IEN String is valid
 ;extrinsic function, all passed by value
 I $G(DIENS)="" Q 0
 I $G(DIFLAGS,"N")'="N" Q 0
 S DIFLAGS=$G(DIFLAGS)
 N DICHAR,DICRSR,DIPIECE,DISEQ,DIOUT,DIVALID
 S DIPIECE="",DISEQ="",DIOUT=0,DIVALID=1
 F DICRSR=1:1 D  I DIOUT Q
 .S DIPIECE=$P(DIENS,",",DICRSR)
 .I DIPIECE="" D  Q
 ..I $P(DIENS,",",DICRSR,999)="" S DIOUT=1 Q
I1 ..I DICRSR=1 Q
 ..S DIOUT=1,DIVALID=0
 ..Q
 .I +DIPIECE=DIPIECE S DIVALID=DIPIECE>0,DIOUT='DIVALID Q
 .I DIFLAGS["N" S DIVALID=0,DIOUT=1 Q
 .S DICHAR=$E(DIPIECE,1,2) I DICHAR'="?+" S DICHAR=$E(DICHAR)
 .I DICHAR'="+",DICHAR'="?",DICHAR'="?+" S DIOUT=1,DIVALID=0 Q
 .I $P(DIPIECE,DICHAR,2,9999)?1N.N D  Q
 ..S DISEQ=$P(DIPIECE,DICHAR,2,999)
 ..S DIOUT=+DISEQ'=DISEQ!$D(DISEQ(DISEQ)),DIVALID='DIOUT Q
I2 .S DIOUT=1,DIVALID=0
 .Q
 Q $E(DIENS,$L(DIENS))=","&DIVALID
 ;
PROOT(DIFILE,DIENS) ;
 ;ENTRY POINT--return the global root of a subfile's parent
 ;extrinsic function, all passed by value
 Q $$ROOT^DILFD($$PARENT(DIFILE),$P(DIENS,",",2,999),1)
 ;
PARENT(DIFILE) ;
 ;ENTRY POINT--return the file number of a subfile's parent
 ;extrinsic function, all passed by value
 Q $G(^DD(DIFILE,0,"UP"))
 ;
PARENTS(DIFILE,DIRULE) ;
 ;IEN--return the file's parents
 ;procedure, passed by ref
 N DIBACK,DIOUT,DIMOM,DITEMP
 S DIOUT=0,DIMOM=DIFILE
 S DITEMP=DIFILE K DIFILE S (DIFILE,DIFILE("C"))=DITEMP
 S DIFILE("L")=$$LEVEL(DIFILE)
 S DIFILE(1)=DIFILE
 I '$D(DIRULE("L",DIFILE)) S DIRULE("L",DIFILE)=DIFILE("L")
 F DIBACK=2:1 D  I DIOUT Q
 .S DITEMP=DIMOM
 .S DIMOM=$G(DIRULE("UP",DITEMP))
PA1 .I DIMOM="" D  I DIOUT Q
 ..S DIMOM=$G(^DD(DITEMP,0,"UP"))
 ..I DIMOM="" S DIOUT=1 Q
 ..S DIRULE("UP",DITEMP)=DIMOM
 ..I '$D(DIRULE("L",DIMOM)) S DIRULE("L",DIMOM)=DIFILE("L")-DIBACK+1
 ..Q
 .S DIFILE(DIBACK)=DIMOM
 .Q
 Q
 ;
LEVEL(DIFILE) ;
 ;IEN--return the file's level (# parents +1)
 ;function, pass by value
 N DIMOM
 I '$G(DIFILE) Q 0
 S DIMOM=$G(^DD(DIFILE,0,"UP"))
 I DIMOM="" Q 1
 Q $$LEVEL(DIMOM)+1
 ;

DIDU2
DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;10/21/94  12:08 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 
HEADER(DIFILE,DIENS,DIMSGA) ;
 ;ENTRY POINT--return the value a file's Header Node should have
 ;extrinsic function, DIENS passed by reference
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DIROOT D HINPUT(.DIFILE,.DIENS,.DIMSGA,.DIROOT) I $G(DIERR) D  Q ""
 . D CLOSE
 N DIHEADER S DIHEADER=$$PIECES12(DIFILE,DIROOT) I $G(DIERR) D  Q ""
 . D CLOSE
 N DIRECENT S DIRECENT=$O(@DIROOT@(" "),-1) I DIRECENT="" S DIRECENT=0
 N DICOUNT,DIRECORD S DICOUNT=0,DIRECORD=0
 F  S DIRECORD=$O(@DIROOT@(DIRECORD)) Q:'DIRECORD  S DICOUNT=DICOUNT+1
 Q DIHEADER_U_DIRECENT_U_DICOUNT
 
HINPUT(DIFILE,DIENS,DIMSGA,DIROOT) ;
 ;evaluate input variables for HEADER call
 I $G(DIMSGA)'="" D
 . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
 S DIFILE=$G(DIFILE) I DIFILE="" D ERR(202,"","","","FILE") Q
 I $G(^DD(DIFILE,.01,0))="" D  Q
 . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q
 . I '$D(^DD(DIFILE,.01)) D ERR(406,DIFILE) Q
 . E  D ERR(502,DIFILE,"",.01)
 S DIENS=$G(DIENS) I DIENS="" S DIENS=","
 I '$$IEN^DIDU1(DIENS) D  Q
 . I '$$IEN^DIDU1(DIENS_",") D ERR(202,"","","","IENS") Q
 . E  D ERR(304,"",DIENS)
 S DIROOT=$G(DIFILE("ROOT")) I DIROOT="" D
 . S DIROOT=$$ROOT^DILFD(DIFILE,DIENS,1,1) Q:DIROOT'=""!$G(DIERR)
 . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q
 . E  D ERR(402,DIFILE,DIENS)
 Q
 
PIECES12(DIFILE,DIROOT) ;
 ;return pieces 1 & 2 of the Header node
 N DIPIECE1,DIPIECE2
 N DINAME S DINAME=$O(^DD(DIFILE,0,"NM","")) I DINAME="" D  Q ""
 . D ERR(408,DIFILE)
 N DIPARENT S DIPARENT=$G(^DD(DIFILE,0,"UP"))
 
P1 I DIPARENT'="" D  ;subfile
 . S DIPIECE1=""
 . I $P(^DD(DIFILE,.01,0),U,2)["W" D  Q
 . . D ERR(407,DIFILE)
 . N DIFIELD S DIFIELD=$O(^DD(DIPARENT,"B",DINAME,""))
 . I DIFIELD="" D  Q
 . . D ERR(501,DIFILE,"","",DINAME)
 . N DINODE S DINODE=$G(^DD(DIPARENT,DIFIELD,0)) I DINODE="" D  Q
 . . D ERR(502,DIFILE,"",DIFIELD)
 . S DIPIECE2=$P(DINODE,U,2) I DIPIECE2="" D  Q
 . . D ERR(502,DIFILE,"",DIFIELD)
 
P2 E  D  ;root file
 . S DIPIECE1=DINAME
 . S DIPIECE2=DIFILE_$$CODES(DIFILE,DIROOT) I $G(DIERR) Q
 I $G(DIERR) Q ""
 Q DIPIECE1_U_DIPIECE2
 
CODES(DIFILE,DIROOT) ;
 ;collect the file characteristics codes
 N DIFIELD S DIFIELD=$P($G(^DD(DIFILE,.01,0)),U,2) I DIFIELD="" D  Q ""
 . I '$D(^DD(DIFILE,.01)) D ERR(501,DIFILE,"","",.01) Q
 . E  D ERR(510,DIFILE,"",DIFIELD)
 N DICODES S DICODES=""
 N DITYPE F DITYPE="D","S","P","V" I DIFIELD[DITYPE S DICODES=DITYPE Q
 I $D(^DD(DIFILE,0,"ID")) S DICODES=DICODES_"I"
 I $D(^DD(DIFILE,0,"SCR"))#2 S DICODES=DICODES_"s"
 N DINODE S DINODE=$G(@DIROOT@(0))
 I DINODE["A" S DICODES=DICODES_"A"
 I DINODE["O" S DICODES=DICODES_"O"
 Q DICODES
 
CLOSE D CALLOUT^DIEFU($G(DIMSGA)):$G(DIMSGA)'="" Q
 
ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
 ;log an error
 N DIPE
 N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
 D BLD^DIALOG(DIERN,.DIPE,.DIPE)
 Q
 

DIDX
DIDX ;SFISC/XAK-BRIEF DD ;11/3/93  15:29
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S D1=D0,DINM=1,DDRG=1,DDL1=14,DDL2=32 G B
 ;
L S DJ(Z)=0
A I DIDX D  G:D1>0 A:^DD(F(Z),"B",DJ(Z),D1)
 . S DJ(Z)=$O(^DD(F(Z),"B",DJ(Z))) S:DJ(Z)="" D1="" Q:DJ(Z)=""  S D1=$O(^(DJ(Z),0))
 . Q
 E  S (D1,DJ(Z))=$O(^DD(F(Z),DJ(Z)))
 I D1'>0 W ! S Z=Z-1 Q
B I $D(DIGR),D1-.01!'DID X DIGR E  G END
 S N=^DD(F(Z),D1,0) D HD:$Y+9>IOSL Q:M=U  W !!?Z+Z-2,$P(N,U,1),?30,S,F(Z),",",D1,S,S
 S X=$P(N,U,2) I X W ?M,$J(+X,8) I $D(^DD(+X,.01,0)),$P(^(0),U,2)["W" W "  WORD-PROCESSING" S X=""
 W ?M,S,S F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K" I X[$E(W) S:W="K" W="MUMPS" D W1 I X["V" D VP0
 G T:X'["P"!X S Y=$P(N,U,3) I Y]"",@("$D(^"_Y_"0))") S W="TO "_$P(^(0),U,1)_" FILE (#"_+$P(X,"P",2)_")" D W1 G T
 S W="***** TO A FILE THAT IS UNDEFINED *******" D W1
T ;
 S W=0
H ;
 W ! I $D(^DD(F(Z),D1,.1))#2 W ?(Z*2),^(.1),"   ",?M
 I X["S" S N=$P(N,U,3) F I=1:1 S Y=$P(N,";",I) Q:Y=""  S W="'"_$P(Y,":")_"' FOR "_$P(Y,":",2)_";" W ?M,"  "_W,!
 I $D(^DD(F(Z),D1,3))#2 S W=^(3) W ?M D W1
RD ;
 I X S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X,W="   Multiple" D W1,L
END S X="" G:M'=U A:Z>1 Q
 ;
W1 W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S I %Y]"" S W=%Y G W1
 D:$Y>IOSL HD Q
 ;
HD S DC=DC+1 D ^DIDH
 Q
VP ;Variable Pointer
 W ?50,W S D1=DJ(Z)
VP0 I '$D(^DD(F(Z),D1,"V",0)) S W="" Q
 S DID1=0,DIMU=0,DID2=0 I '$D(DDRG) D RT
 S W="FILE  ORDER  PREFIX    LAYGO  MESSAGE" W !?(Z+Z+12),W G Q:M=U
VP1 S DID2=$O(^DD(F(Z),D1,"V",DID2)) S:DID2="" DID2=-1 G:DID2'>0 VP2 S DIDV=^(DID2,0) I '$D(^DIC(+DIDV,0)) S DIDV(+DIDV)=""
 S DIVP=$P(DIDV,U),DDLF=(Z+Z+15) I $L(DIVP)>4 W !?(DDLF-$L(DIVP))+1,DIVP
 E  W !?DDLF,DIVP
 W ?(DDLF+5),$P(DIDV,U,3),?(DDLF+10),$P(DIDV,U,4),?(DDLF+23),$P(DIDV,U,6) S DDL3=DDL2,DDL2=DDLF+27,W=$P(DIDV,U,2) D W1^DIDH1 S DDL2=DDL3 S:$P(DIDV,U,5)["y" DIMU=1 D:$Y+4>IOSL HD G ND^DID1:M=U,VP1
VP2 I DIMU S DIDVI=0 F  S DIDVI=$O(^DD(F(Z),D1,"V",DIDVI)) Q:DIDVI'>0  I $D(^(DIDVI,1)) S %=^(0) D VP3 Q:M=U
 S DIDV=0 F  S DIDV=$O(DIDV(DIDV)) Q:DIDV'>0  S W="!! FILE "_DIDV_" DOES NOT EXIST !!" D W^DID1 Q:M=U
Q W ! K DID2,DIMU,DID1,DIDV,DIDVI S W="" Q
VP3 ;
 W !?(Z+Z+12),"SCREEN"_$S('$D(DINM):" ON FILE "_$P(%,U)_":",1:" EXPLANATION ON FILE "_$P(%,U)_":") S W=" "_$S('$D(DINM):^(1),1:$S($D(^(2)):^(2),1:"")) D W^DID1:'$D(DINM),W^DIDH:$D(DINM)
 Q
RT F W="Required","Add New Entry without Asking","Multiply asked","audited" I X[$E(W,1) S W=" ("_W_")" W:($L(W)+$X)'<IOM ! D W^DID1 G ND^DID1:M=U
 W ! I $D(^DD(F(Z),DJ(Z),.1)),^(.1)]"" W !?(Z+Z+12),^(.1),"   ",?M
 Q
AH W !,"ALPHABETICALLY BY LABEL" D YN^DICN Q:%<0  S:%=1 DIDX=1,BY="@.01"
 I '% W !?5,"Enter YES to list the fields ALPHABETICALLY BY LABEL.",!?5,"Enter NO to list the fields by NUMBER." S %=2 G AH
 Q

DIE
DIE ;SFISC/GFT,XAK-PROC.DR-STR ;2/10/95  06:54
 ;;21.0;VA FileMan;**19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DB I DIE S DIE=^DIC(DIE,0,"GL")
 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)
GO Q:DIE?1"^DIA(".E  K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D
 . N %
 . F %=1:1 Q:'$G(DA(%))  S DIEDA(%)=DA(%)
 . S DIEDA=DA
 . Q
 S DL=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17
 S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S")
MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR
 S DI=$P(DH,":",1) I 'DI G K:DI=0,PB
J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH=""
 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
 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))
 S DQ(DQ)=DZ K DZ,DIG G Y
K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S
NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
S I $S<2000,DQ,'$D(DE(DQ+1)) G H
 S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI
Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1)
 I $D(^(1))!($P(DQ(DQ),U,2)["a") S DE=0,DB=DM,DM=0 F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1  S DE(Y)=DQ,DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2)
 I  S:DE="" DE=-1
 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)
 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)
 I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y)
 E  S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y
EQ G MR:DI=DM,NX:DM S DM=DB K DB G D
 ;
INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))"
Q Q
MORE ;
 D INI G MR:DI=DM,NX:DI'[U S DI=+DI G S:$D(^DD(DP,DI)),MR
JMP ;
 D INI G J
 ;
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
 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
E S DK=DK-1,(DI,DM)=1
D G DQ^DIED
H S DI=DI_U G D
M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9
 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
 I $D(^(DG,0)) S D=$P(^(0),U,3,4)
 E  S D=$O(^(0)) S:D="" D=-1
DE I D>0 S Y=Y_U_D I DP(0)-Y,$D(^(+D,0)) S DE(DQ)=$P(^(0),U,1)
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
 I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H
 D
 .Q:DH'[$C(126)
 .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R")
 .S $P(%,U)=$S(DIEA="T"&$D(^DD(+$P(%,U,2),.01,.1)):^(.1),1:DIEA)
 .Q
 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
 ;
D1 Q:D'>0  S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1
 ;
B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ
 ;  
TEM 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
 S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU")
 S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR
 S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U)
 Q
 ;
 ;Silent call concerning editing and filing of data.
 ;
FILE(DIEFFLAG,DIEFAR,DIEFOUT) ;
 G FILEX^DIEF
 ;
WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;
 G WPX^DIEFW
 ;
HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
 G GETX^DIEH
 ;
VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ;
 G VALX^DIEV
 ;
CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ;
 G CHKX^DIEV
 ;
UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD
 ; ENTRY POINT--update database
 ; procedure, all passed by value
 G ADDX^DICA
 ;

DIE0
DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;12/22/93  10:15
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X
 I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " G X
 I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " G X
 I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0
 S X=$P(X,U,2),DIC(0)="E"
OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1
 I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DL,DP)) DR(DL,DP)=DR
 S DDBK=0,DIC="^DD(DP," D ^DIC I Y>0 D S
 E  W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED "
 K DTOUT,DIC,DDR,DDBK,DDFND,DDONE,A0,A1,A2
 I Y<0 S DG=DK,DH=":"_DM G X
 S DI=$S(DH[":":+Y,1:DH),DK=DG D ^DIE1:$D(DG)>9 K DG,DB,DE,DQ,DIFLD S DQ=0 G JMP^DIE
X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1
 ;
BR ;
 S Y=U X DQ(0,DQ) G A^DIED:$D(Y)[0,A^DIED:Y=U S D=$S(+Y=Y:9999,1:DQ),X="" I 0[Y S DQ=0 G OUT
D S D=D+1 I '$D(DQ(D)) G D:$D(DQ(0,D)) S DQ=9999,X=Y,DIC(0)="FO" G OUT
 G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED
 ;
O ;
 K DQ S (DI,DV,DM)=0 D DUZ I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC
 S DQ=0 G MORE^DIE
 ;
DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%))  S DIEC(DL,%)=DA(%)
 K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA
 S DIEL=0,(D0,DA)=X Q
 ;
DUZ Q:X=""!(DUZ(0)="@")
 ;S DIFILE=$P(DC,U,2),DIAC="WR" D ^DIAC K DIAC,DIFILE G:'% 3
 Q
3 ;W $C(7),!?7,"(YOU DO NOT HAVE 'WRITE ACCESS' TO THE '"_$P(^DIC($P(DC,U,2),0),U)_"' FILE)" S X=""
 Q
 ;
DIEZ ;
 D DUZ I X="" G @("A"_U_DNM)
 S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO
 ;
A I $D(DR(DL,DP))>9 D OA
 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
 S DK=DG,DI=X D ^DIE1 G JMP^DIE
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
 S %=-1 Q
 ;
E ;
 I X="@" Q:DV'["I"  G NO
 Q:X[U!(X?."?")!DV!$D(DITC)
NO W:'$D(DB(DQ)) $C(7),"   NO EDITING!!" K X
Q Q
S ;reg or ovfl, out= $T
 S (%,DDFND)=0,DDR=DR(DL,DP),DDBK=0,Y=+Y
 I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1
 D S1 I DDFND Q
 I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DL,DP,%)) Q:%=""  S DDR=DR(DL,DP,%) D S1 Q:DDONE!DDFND
 Q
S1 ;selectable?
 S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="")
 I DDFND S DOV=%,DR=$S($D(DR(DL,DP,%)):DR(DL,DP,%),$D(DR(DL,DP)):DR(DL,DP),1:"")
 Q
S2 ;parse for ;-piece
 S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH
 ;list
 I 'DDBK,+DH=Y S DDFND=1 Q
 I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q
 I DDBK,+DH=Y S DDFND=1 Q
 Q:$P(DH,"//")'[":"
 ;range
 S A0=+$P(DH,":",1),A1=+$P(DH,":",2)
 I 'DDBK,Y'<A0,Y'>A1 S DDFND=1 Q
 F A2=A0-.000001:0 S A2=$O(^DD(DP,A2)) Q:A2>A1!'A2  S:A2=DIFLD&(A2'=Y)&DDBK DDONE=1 Q:DDONE  I A2=Y,(A2'>DIFLD) S DDFND=1 Q
 Q

DIE1
DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;09:14 AM  7 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q
 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
 I DU'<0 S ^(DU)=DV,DU=-2
 G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
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
PC S $P(DV,"^",DW)=DG(DQ) G Y
 ;
IX S 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)
 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)
E1 K DIFLD,DG,DB,DE,DIANUM S DQ=0 Q
 ;
B ;
 I '$D(DB(DQ)) S X="?BAD" G ^DIEQ
 S DC=DQ,DIK="",DL=1
OUT ;
 D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY
 ;
E ;
 I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1
Q K Y
QY I $D(DTOUT),$D(DIEDA) D
 . N % K DA
 . F %=1:1 Q:'$D(DIEDA(%))  S DA(%)=DIEDA(%)
 . S DA=DIEDA
 . Q
 K:$D(DTOUT) DG,DQ
 K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q
 ;
M ;
 S DD=X,DIC(0)=$P("QE","^",'$D(DB(DQ)))_"LM",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)
 E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC
 I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) 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
 S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1
 ;
DOWN D S,DIE1,DDA S DIE=DIC Q
 ;
S S DIOV(DL)=$S('$D(DOV):0,1:DOV) K DOV
 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)
 Q
 ;
DDA F X=DL+1:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
 S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_"""," Q
 ;
UDA S DA=DA(1) F X=2:1 Q:'$D(DA(X))  S DA(X-1)=DA(X) K DA(X)
 K DA(DL)
 Q
N ;
 D DOWN S DA=$P(DC,U,4),DI=.01 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
D1 S @("D"_DIEL)=DA
G G MORE^DIE
 ;
UP ;
 Q:$D(DTOUT)  S DP(0)=DP I $D(DIEC(DL)) D DIEC G U
U1 D UDA S DIEL=DIEL-1
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)
 G G
 ;
DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%))  S DA(%)=DIEC(DL,%)
 F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL))  S @("D"_DIEL)=DIEC(DL,0,DIEL)
 S DIEL=DIEL-1 K DIEC(DL)

DIE17
DIE17 ;SFISC/GFT-COMPILED TMPLT UTIL ;12:22 PM  18 Jul 1996
 ;;21.0;VA FileMan;**19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $D(DTOUT) S X="" G OUT
 G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM)
 I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " S D="" G X
 I $D(DIE("NO^")),X?1"^"1.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " S D="" G X
 I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE17
 S X=$P(X,U,2),DIC(0)="E" G OUT
Z ;
 S DL=1,X=0
OUT ;
 I 0[X S DM=DW D FILE G ABORT:DL=1,R
 S DIC="^DD("_DP_"," G OJ:'$D(^DIE(DIEZ,"AB")) S DIEZAB=$S(DL=1:U,1:DNM(DL,0)_U_DNM(DL)) I X?1"@".N,$D(^("AB",DIEZAB,X)) S DNM=^(X) G JMP
 S DDBK=0 I $D(DIE("NO^")),DIE("NO^")["BACK" D DR S DDBK=1,DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)) D S^DIE0"
 E  S DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)),DIC(0)[""F""!'$D(^(Y,""///""))"
 S DIC="^DD("_DP_"," D ^DIC S DIC=DIE I Y<0 S D="" W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED "
 I DDBK K DR S DR(1,DP)=^DIE(DIEZ,"ROU"),DR=DI
 K A0,A1,DDBK,DIC,DTOUT G X:Y<0 S DNM=^DIE(DIEZ,"AB",DIEZAB,+Y)
JMP K DIEZAB D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y
 ;
OJ I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ)
 E  S DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ)),DIC(0)[""F""!'$D(^(DIEZ,""///""))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ)
 G JMP
F ;
 S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q
FILE ;
 K DQ Q:$D(DG)<9  S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
 I DU'<0 S ^(DU)=DV,DU=-2
 G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
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
PC S $P(DV,U,DW)=DG(DQ) G Y
 ;
IX D @DE(DQ)
K K DE(DQ)
E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K
 K DG,DE,DIFLD S DQ=0 Q
1 ;
 D FILE
R D UP G @("R"_DQ_U_DNM)
 ;
UP S DNM=DNM(DL),DQ=DNM(DL,0) K DTOUT,DNM(DL) I $D(DIEC(DL)) D DIEC^DIE1 G U
 S DIEL=DIEL-1,%=2,DA=DA(1) K DA(1)
DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA
U S DL=DL-1 Q
 ;
X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G Z:$D(DB(DQ))
B G @(DQ_U_DNM)
N ;
 D DOWN S DA=$P(DC,U,4),D=0 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
D1 S @("D"_DIEL)=DA G @(DGO)
M ;
 S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)=$P("QE",U,'$D(DB(DNM(DL,0))))_"LM" I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
 E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC
 I Y>0 S DA=+Y,X=$P(Y,U,2),D=$P(Y,U,3) G D1
 D UP G @(DQ_U_DNM)
 ;
DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE
 F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%)
 S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DIEL=DIEL+1 Q
ABORT D E S Y(DM)="" Q
0 ;
 D FILE
E K DIP,Y,DE,DOW,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB,DIEL,DGO Q
DR ;
 N F,DA I $E(DR)="[" S %X="^DIE(DIEZ,""DR"",",%Y="DR(" D %XY^%RCR S DR=DR(DL,DP) Q
 S F=0 D DICS^DIA F DDW=1:1 S DDW1=$P(DR,";",DDW) Q:DDW1=""  I $D(^DD(DI,+DDW1,0)),+$P(^(0),U,2)!(DDW1[":") S X=+DDW1,D(F)=+$P(DDW1,":",2) S:'D(F) D(F)=X D RANGE^DIA1
 K DDW,DDW1 Q

DIE2
DIE2 ;SFISC/GFT,XAK-DELETE AND ENTRY ;2/8/94  09:26
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D F,DL Q:$D(DTOUT)  G B^DIED:Y=2,A^DIED:Y,UP^DIE1:DL>1,Q^DIE1
 ;
F S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD Q
 ;
Z D DL S DU="" I Y=2 G @(DQ_U_DNM)
 I Y G @("A^"_DNM)
 G R^DIE9:DL>1,E^DIE9
DL ;
 S %=DP,X=D,Y=$P(DQ(DQ),U,4)="0;1"
 G X:$D(DE(DQ))[0,X:DV["R"&'Y,S:DP<0,DD:DUZ(0)="@" I DV S %=+$P(DC,U,2),X=.01
 G DD:DP<2 I $D(DIDEL),DIDEL\1=(DP\1) G DD
 I Y,$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) G DD:$D(^DD(DP,0,"UP"))!DV,DAR:'$S($D(^VA(200,DUZ,"FOF",DP)):1,1:$D(^DIC(3,DUZ,"FOF",DP))),DAR:'$P(^(DP,0),U,3),DD
 I Y,$D(^DIC(%,0,"DEL")) S X=^("DEL")
 E  G DD:'$D(^DD(%,X,8.5)) S X=^(8.5)
 G DD:X="" F %=1:1:$L(X) G DD:DUZ(0)[$E(X,%)
DAR W !,"'DELETE ACCESS' REQUIRED!!"
X I $D(DB(DQ)) D N G A
 W:'$D(DIER) $C(7),"??" W:DV["R"&'$D(DIER) "  Required" G R
DD G MD:DV S DH=0,DU=0 F  S DH=$O(^DD(DP,D,"DEL",DH)) Q:DH=""  I $D(^(DH,0)) X ^(0) Q:$D(DTOUT)  G X:$T
 S DH=-1,X=DQ(DQ) I Y,$E(@(DIE_"0)"))'=U S X=^(0)
 D D G R:X I Y S X=DE(DQ) D DEL:$D(DIU(0)) K DE,DG,DQ,DB S DIK=DIE D ^DIK S Y=0 K:DL<2 DA Q
S S X="",DG($P(DQ(DQ),U,4))=""
A S Y=1 Q
 ;
D I $D(DB(DQ)) S X=0 Q
 W $C(7),!?3,"SURE YOU WANT TO DELETE"
 I Y W " THE ENTIRE " W:DV'["D"&(DV'["P")&(DV'["V") "'"_DE(DQ)_"' " W $P(X,U,1)
 S %=0,X=0 D YN^DICN Q:%=1  S X=1 W:$X>55 !?9
N I $D(DE(DQ))#2,'$D(DDS) W:'$D(ZTQUEUED) $C(7),"  <NOTHING DELETED>"
 Q
 ;
MD G X:DV["R"&($P(DC,U,5)=1) S DH=0,DU=0 F  S DH=$O(^DD(+$P(DC,U,2),.01,"DEL",DH)) Q:DH=""  I $D(^(DH,0)) D DDA X ^(0) D UDA G X:$T
 S DH=-1,Y=DC>1,X=$E(DQ(DQ),8,99) D D
 I 'X D DDA S DIK=DIC D ^DIK,UDA K DE(DQ) S X=$P(@(DIK_"0)"),U,3,4),DC=$P(DC,U,1,3)_U_X,DIC=DIE S:$D(^(+X,0)) DE(DQ)=$P(^(0),U,1)
R S Y=2 Q
 ;
DDA F X=DL+1:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
 K DA(DL+2) S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DA=$P(DC,U,4) Q
 ;
UDA S DA=DA(1) F X=2:1 Q:'$D(DA(X))  S DA(X-1)=DA(X) K DA(X)
 Q
QS ;
 G ^DIEQ
QQ ;
 G QQ^DIEQ
 Q
DEL I '$S($D(^VA(200,"AFOF",DA)):1,1:$D(^DIC(3,"AFOF",DA))) Q
 S DA(1)="",DIFOF=DA
 F P=0:0 S DA(1)=$S($D(^VA(200,"AFOF")):$O(^VA(200,"AFOF",DA,DA(1))),1:$O(^DIC(3,"AFOF",DA,DA(1)))) Q:'DA(1)  I $S($D(^VA(200,DA(1),"FOF",DA)):1,1:$D(^DIC(3,DA(1),"FOF",DA))) S DIK=$S($D(^VA(200)):"^VA(200,",1:"^DIC(3,")_DA(1)_",""FOF""," D ^DIK
 K DA S DA=DIFOF K DIFOF
 Q
V ;
 G ^DIE3

DIE3
DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;9/27/94  11:08
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
V ;
 S DIEX=X ;I $D(DNM) S DIDS=D
 G ALL:X'["." S DIVP=$P(X,"."),X=$P(X,".",2,999),Y=-1,A9=1 I X="" G Q
 I DIVP]"",$D(^DD(DP,DIFLD,"V","P",DIVP)) D FND G Q
 I DIVP="" G ALL
 S X="" F %=0:0 S X=$O(^DD(DP,DIFLD,"V","M",X)) Q:X=""  I $P(X,DIVP)="" S DIVP=X,X=$P(DIEX,".",2,999) D FND G Q:Y>0 S X=$P(DIEX,".")
 F DIVP=0:0 S DIVP=$O(^DD(DP,DIFLD,"V",DIVP)) Q:+DIVP'>0  I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999) D DIC G Q:Y>0 S X=$P(DIEX,".")
 I A9 S X=DIEX,A9=0 G ALL
 G Q
 ;
ALL F DIVP1=0:0 S DIVP1=$O(^DD(DP,DIFLD,"V","O",DIVP1)) Q:+DIVP1'>0  S DIVP=DIVP1 D FND Q:Y>0  S X=DIEX
 G Q
 ;
FND S DIVP=+$O(^(DIVP,0)) I $D(^DD(DP,DIFLD,"V",DIVP,0)) S DIVPDIC=^(0) D DIC
 I Y>0 S A9=0
 Q
 ;
DIC I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 Q
 I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 Q
 I $D(DIVP1),'$D(DB(DQ)),'$G(DIQUIET) D H1
 S DIC=^DIC(+DIVPDIC,0,"GL"),DIC(0)="MD"_$E("E",'$D(DB(DQ))&'$D(DIR("V")))_$E("L",$P(DIVPDIC,U,6)="y")_$E("Z",$D(DDS)) I $P(DIVPDIC,U,5)="y",$D(^DD(DP,DIFLD,"V",DIVP,1)),^(1)]"" X ^(1)
 I $D(DIR)=10,'$D(DDS) S DIC(0)=$P(DIC(0),"L")_$P(DIC(0),"L",2)
 D ^DIC S X=+Y_";"_$E(DIC,2,99) K:Y<0 X S %=1
 I Y>0,$D(DIVP1),'$D(DB(DQ)),'$P(Y,U,3),$P(^DIC(+DIVPDIC,0),U,2)'["O",'$G(DIQUIET) D S1
 D  Q 
 .N DICV
 .I $D(DIC("V")) S DICV=DIC("V")
 .K DIC S DIC=DIE S:$D(DICV) DIC("V")=DICV
 .Q
 ;
S1 S A1="Q",DST=%_U_"        ...OK" D S S:%=2!(%<0) Y=-1 Q
 ;
H S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K DST Q
 ;
H1 ;also called by DICM3
 W:'$D(DDS) !
 S A1="T",DST=$$EZBLD^DIALOG(8070,$P(DIVPDIC,U,2))
S I $D(DDS) D H S DDD=1 D ^DDSU K DDD G QS
 I A1["T" W !,DST G QS
 I A1["Q" S %=+$P(DST,U,1) W !,$P(DST,U,2) D YN^DICN G QS
 I A1["X" X DST
QS K A1,DST Q
 ;
Q K A1,DIVP1,DIVP,DIVPDIC,A9
 I $D(DNM) G:Y>0 @("V^"_DNM) S X=DIEX K DIEX G X^DIE17:'$D(DB(DQ)),B^DIE17
 K DIEX Q:$D(DIR)  G V^DIED:Y>0,X^DIED:'$D(DB(DQ)),B^DIE1
 ;
 ;#8070  Searching for a |filename|

DIE9
DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;12/22/93  10:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM)
 I $D(DIE("NO^")),DIE("NO^")="OUTOK"'&(X=U) W $C(7),!?3,"Sorry, ""^"" is not allowed!" G B
 S X=$P(X,U,2),DIC(0)="E"
OUT I 0[X S DM=DW D FILE G ABORT:DL=1,R
 I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ)
 E  S DIC="^DD("_DP_",",DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ)
 D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y
 ;
F ;
 S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q
FILE ;
 K DQ Q:$D(DG)<9  S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
 I DU'<0 S ^(DU)=DV,DU=-2
 G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
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
PC S $P(DV,U,DW)=DG(DQ) G Y
 ;
IX 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)
 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)
K K DE(DQ)
E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K
 K DG,DE,DIFLD S DQ=0 Q
 ;
AST S E=DQ(DQ),Y=$F(E," D ^DIC"),%=8
 I 'Y S Y=$F(E," D IX^DIC"),%=10 G V^DIED:'Y
 S %DD=Y+1 X $P($E(E,1,Y-%),U,5,99) G V^DIED:'$D(DIC("S"))
 S DICSS=DIC("S") D ^DIC S X=+Y
 I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS I '$T S D=DA,DA=Y,DIK=DIC D ^DIK K DICSS S DA=D,DV=$P(E,U,2),DU=$P(E,U,3) G X^DIED
 K DICSS X:Y>0 $E(E,%DD,999) K %DD G X^DIED:'$D(X),X^DIED:X<0,Z^DIED
1 ;
 D FILE
R D UP G @("R"_DQ_U_DNM)
 ;
UP S DNM=DNM(DL),DQ=DNM(DL,0),%=2 I $D(DIEC(DL)) D DIEC^DIE1 G U
 S DA=DA(1) K DA(1)
DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA
U K DTOUT,DNM(DL) S DL=DL-1 Q
 ;
X W:'$D(ZTQUEUED) $C(7),"??"
B G @(DQ_U_DNM)
 ;
N D DOWN S DA=$P(DC,U,4),D=0,^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
D1 S @("D"_(DL-1))=DA G @(DGO)
 ;
M S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)=$P("QE",U,'$D(DB(DNM(DL,0))))_"LM" I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
 E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC I Y'>0 D UP G @(DQ_U_DNM)
 S DA=+Y,X=$P(Y,U,2),D=$P(Y,U,3) G D1
 ;
DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE
DDA F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%)
 S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_"""," Q
 ;
ABORT D E S Y(DM)="" Q
 ;
0 ;
 D FILE
E K DIP,Y,DE,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB

DIED
DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;1/24/96  10:57
 ;;21.0;VA FileMan;**1,13,19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
O D W W Y W:$X>48 !?9
 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
 I Y]"" W "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
TR Q:$P(DQ(DQ),U,2)["K"&(DUZ(0)'="@")  R X:DTIME E  S (DTOUT,X)=U W $C(7)
 Q
W I $P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") Q
 I $D(DIE("W")) X DIE("W") Q
 W !?DL+DL-2,$P(DQ(DQ),U,1)_": " Q
 ;
DQ ;
 S:$D(DTIME)[0 DTIME=300 S DQ=1 G B
A K DQ(DQ) S DQ=DQ+1
B S DIFLD=$S($D(DIFLD(DQ)):DIFLD(DQ),1:-1)
 I '$D(DQ(DQ)) G E^DIE1:'$D(DQ(0,DQ)),BR^DIE0
RE ;
 S DIP=$P(DQ(DQ),U,1),DV=$P(DQ(DQ),U,2),DU=$P(DQ(DQ),U,3) G:DV["K"&(DUZ(0)'="@") A G PR:$D(DE(DQ)) D W,TR I $D(DTOUT) K DQ,DG G QY^DIE1
N I X="" G A:DV'["R",X:'DV,X:$P(DC,U,2)-DP(0),A
RD G ^DIE0:X[U,^DIE2:X="@",^DIEQ:X?."?"
 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DIP)) S X=^(DIP) I DV'["D",DV'["S" W "  "_X
T G M^DIE1:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
 K DDER G X
P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G AST:DV["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
 G V:DV'["N" I $L($P(X,"."))>24 K X G Z
 I $P(DQ(DQ),U,5,99)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
V S DIER=1 X $P(DQ(DQ),U,5,99) K DIER,YS
Z K DIC("S"),DLAYGO I $D(X),X?.ANP,X'=U S DG($P(DQ(DQ),U,4))=X S:DV["d" ^DISV(DUZ,"DIE",DIP)=X G A
X W:'$D(ZTQUEUED) $C(7) W:'$D(DDS)&'$D(ZTQUEUED) "??"
 G B^DIE1
 ;
PR I $D(DE(DQ,0)) S Y=DE(DQ,0) G F:Y?1"/".E I $D(DE(DQ))=10 D Y:$E(Y,1)=U,O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
 S DG=DV,Y=DE(DQ),X=DU I DG["O",$D(^DD(DP,DIFLD,2)) X ^(2) G S
R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G S:'$D(^(Y,0)) S Y=$P(^(0),U,1),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G S:'$D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";",1) S:%]"" Y=%
S D O I $D(DTOUT) K DQ,DG G QY^DIE1
 I X="" S X=DE(DQ) X:$D(DICATTZ) $P(DQ(DQ),U,5,99) G A:'DV,A:DC<2 G N^DIE1
 G RD:DQ(DQ)'["DINUM" D E^DIE0 G RD:$D(X),PR
 ;
F S DB(DQ)=1,X=$E(Y,2,999),DH=$F(DQ(DQ),"%DT=""E") I DH S DQ(DQ)=$E(DQ(DQ),1,DH-2)_$E(DQ(DQ),DH,999)
 I X?1"/".E S X=$E(X,2,999),DH=""
 X:$E(X,1)=U $E(X,2,999) G:X="" A:'DV,A:'$P(DC,U,4),N^DIE1 I $D(DE(DQ))#2,DV["I"!(DQ(DQ)["DINUM") D E^DIE0
 G X:'$D(X),RD:DH]"",RD:X="@",Z
 ;
Y X $E(Y,2,999) S Y=X I DV["D",Y?7N.NP X ^DD("DD")
Q Q
 ;
AST G V:DV["'",AST^DIE9
RW G RW^DIR2
SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
 D ^DIR I 'DDER S %=Y(0),X=Y

DIEF
DIEF ;SFISC/DPC-FILER DRIVER ;11/9/94  13:10
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FILE(DIEFFLAG,DIEFAR,DIEFOUT,DIEFADAR) ;
FILEX ;
 N DIEFF,DIEFCNOD,DIEFNODE,DIEFSPOT,DIEFDAS,DIEFIEN,DIEFRFLD,DIEFFLD,DIEFFVAL,DIEFOVAL,DIEFNVAL,DIEFTSRC,DIEFLOCK,DIEFECNT
 S DIEFFLAG=$G(DIEFFLAG)
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 I '$$VERFLG^DIEFU(DIEFFLAG,"ISKEO") G OUT
 I '$$VROOT^DIEFU(DIEFAR) G OUT
 I '($D(@DIEFAR)\10) D BLD^DIALOG(305,DIEFAR,DIEFAR) G OUT
 I DIEFFLAG["K" N DIEFNOLK,DIEFLCKS D LOCK I DIEFNOLK D:$D(DIEFLOCK) UNLOCK G OUT
 D DRIVER
 I $D(DIEFLOCK) D UNLOCK
 I DIEFFLAG'["S",'$G(DIERR) K @DIEFAR
OUT I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT)
 Q
LOCK ;
 S (DIEFNOLK,DIEFLCKS)=0,DIEFF=""
 F  S DIEFF=$O(@DIEFAR@(DIEFF)) Q:DIEFF=""  D  Q:DIEFNOLK
 . I '$$VFILE^DIEFU(DIEFF,"D") S DIEFNOLK=1 Q
 . S DIEFDAS=""
 . F  S DIEFDAS=$O(@DIEFAR@(DIEFF,DIEFDAS)) Q:DIEFDAS=""  D  Q:DIEFNOLK
 . . I '$$GOODIEN(DIEFDAS) S DIEFNOLK=1 Q
 . . N DIEFDA D DA^DIEFU(DIEFDAS,.DIEFDA)
 . . S DIEFLCKS=DIEFLCKS+1
 . . S DIEFLOCK(DIEFLCKS)=$$ROOT^DIQGU(DIEFF,.DIEFDA)_DIEFDA_")"
 . . L +@DIEFLOCK(DIEFLCKS):1 E  D
 . . . S DIEFNOLK=1
 . . . N E S E("FILE")=DIEFF,E("IENS")=DIEFDAS D BLD^DIALOG(110,"",.E)
 Q
UNLOCK ;
 N I
 F I=1:1:DIEFLCKS L -@DIEFLOCK(I)
 Q
DRIVER ;
 S DIEFF=""
 F  S DIEFF=$O(@DIEFAR@(DIEFF)) Q:DIEFF=""  D
 . I DIEFFLAG'["K",'$$VFILE^DIEFU(DIEFF,"D") Q
 . S DIEFDAS=""
 . F  S DIEFDAS=$O(@DIEFAR@(DIEFF,DIEFDAS)) Q:DIEFDAS=""  D
 . . S DIEFIEN=DIEFDAS
 . . I ($E(DIEFIEN)="?"!($E(DIEFIEN)="+")),$G(DIEFADAR)]"" S DIEFIEN=$$ADDCONV^DIEF1(DIEFIEN,DIEFADAR)
 . . I '$$GOODIEN(DIEFIEN) Q
 . . N DA,I,DEPTH,D
 . . S DEPTH=$L(DIEFIEN,",")-1
 . . F I=1:1:DEPTH S D="D"_(DEPTH-I) N @D S (DA(I-1),@D)=$P(DIEFIEN,",",I)
 . . S DA=DA(0) K DA(0)
 . . I '$$VENTRY^DIEFU(DIEFF,DIEFIEN,"D") Q
 . . N DOREPL S DIEFRFLD="",DOREPL=0
 . . F  S DIEFRFLD=$O(@DIEFAR@(DIEFF,DIEFDAS,DIEFRFLD)) Q:DIEFRFLD=""  D 
 . . . N DIEFNG
 . . . S DIEFFLD=$$CHKFLD^DIEFU(DIEFF,DIEFRFLD) I 'DIEFFLD Q
 . . . I DIEFFLD=.001 D BLD^DIALOG(520,".001",".001") Q
 . . . S DIEFNVAL=@DIEFAR@(DIEFF,DIEFDAS,DIEFRFLD)
 . . . I DIEFFLAG["E" D VAL Q:$D(DIEFNG)
 . . . I DIEFFLD=.01,"@"[DIEFNVAL D PT01DEL Q
 . . . S DIEFSPOT=" " D GLRF^DIOU(DIEFF,DIEFFLD,.DIEFNODE,.DIEFSPOT)
 . . . I DIEFNODE'=$G(DIEFCNOD) D:DOREPL REPLACE S DIEFCNOD=DIEFNODE D RETRIEVE
 . . . I DIEFNVAL="@" S DIEFNVAL=""
 . . . D PUTDATA^DIEF1 Q:$D(DIEFNG)
 . . . I DIEFNVAL'=$G(DIEFOVAL) D XRFAUD
 . . D REPLACE:DOREPL K DIEFCNOD
 Q
PT01DEL ;
 I '$D(^DD(DIEFF,0,"UP")) D  Q
 . N INT,EXT
 . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD
 . D BLD^DIALOG(712,.INT,.EXT)
 S DIEFECNT=$G(DIERR)
 N DIK S DIK=$$ROOT^DIQGU(DIEFF,.DA) D ^DIK
 I DIEFECNT'=$G(DIERR) D HKERR^DILIBF(DIEFF,DIEFIEN,DIEFFLD,"cross reference")
 Q
VAL ;
 N DIEFTYPE,DIEFINT
 D DTYP^DIOU(DIEFF,DIEFFLD,.DIEFTYPE) Q:DIEFTYPE=5
 D VAL^DIEV(DIEFF,DIEFIEN,DIEFFLD,"",DIEFNVAL,.DIEFINT)
 I DIEFINT'=U S DIEFNVAL=DIEFINT Q
 S DIEFNG=1
 Q
REPLACE ;
 S @DIEFCNOD=DIEFFVAL,DOREPL=0
 Q
RETRIEVE ;
 S DIEFFVAL=$G(@DIEFCNOD)
 Q
 ;
XRFAUD ;
 I $D(^DD(DIEFF,"IX",DIEFFLD)) D REPLACE:$G(DOREPL),IX,RETRIEVE:$D(DOREPL)
 I $D(^DD(DIEFF,"AUDIT",DIEFFLD)) D AUDIT
 Q
IX ;
 N X,DIEFSORK
 I DIEFOVAL'="" S DIEFSORK=2 D FIRE
 I "@"'[DIEFNVAL S DIEFSORK=1 D FIRE
 Q
FIRE ;
 N DIEFI S DIEFI=0
 F  S DIEFI=$O(^DD(DIEFF,DIEFFLD,1,DIEFI)) Q:DIEFI=""  D
 . N I,Y,DIG,DIH,DIU,DIV,XMB,XMY
 . S X=$S(DIEFSORK=1:DIEFNVAL,1:DIEFOVAL)
 . N DIEFECNT S DIEFECNT=$G(DIERR)
 . X ^(DIEFI,DIEFSORK) ;Naked indicator set in For loop, FIRE+2
 . I DIEFECNT'=$G(DIERR) D HKERR^DILIBF(DIEFF,DIEFIEN,DIEFFLD,"cross reference")
 Q
AUDIT ;
 N X,DP,DG,DIIX N DIANUM,C,Y
 S DP=DIEFF,DG=1
 I DIEFOVAL]"" S X=DIEFOVAL,DIIX="2^"_DIEFFLD D AUDIT^DIET
 I "@"'[DIEFNVAL,(DIEFOVAL]""!(^DD(DIEFF,DIEFFLD,"AUDIT")'="e")) S X=DIEFNVAL,DIIX="3^"_DIEFFLD D AUDIT^DIET
 Q
 ;
GOODIEN(DIEFIEN) ;
 I '+DIEFIEN!($E(DIEFIEN,$L(DIEFIEN))'=",") D  Q 0
 . D BLD^DIALOG(203,"IENS","IENS")
 Q 1

DIEF1
DIEF1 ;SFISC/DPC-FILER UTILITIES ;12/21/94  08:50
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOAD(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ;
LOADX ;
 N DIEFIEN
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 I $G(DIEFDAS)']"" D BLD^DIALOG(202,"IENS","IENS") G OUT
 I $E(DIEFDAS,$L(DIEFDAS))="," S DIEFIEN=DIEFDAS
 E  S DIEFIEN=$$IEN^DIEFU(.DIEFDAS)
 I '$$VROOT^DIEFU(DIEFAR) G OUT
 I '$$VFILE^DIEFU(DIEFF,"D") G OUT
 S DIEFFLD=$$CHKFLD^DIEFU(DIEFF,DIEFFLD) G:'DIEFFLD OUT
 I $G(DIEFFLG)["R",'$$VENTRY^DIEFU(DIEFF,DIEFIEN,"D") G OUT
 S @DIEFAR@(DIEFF,DIEFIEN,DIEFFLD)=DIEFVAL
OUT I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT)
 Q
 ;
FLDNUM(DIEFF,DIEFFDNM) ;
FLDNUMX ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 I '$$VFILE^DIEFU(DIEFF,"D") Q 0
 N DIEFFNUM
 I $D(^DD(DIEFF,"B",DIEFFDNM)) D  Q DIEFFNUM
 . S DIEFFNUM=$O(^DD(DIEFF,"B",DIEFFDNM,""))
 . I $O(^DD(DIEFF,"B",DIEFFDNM,DIEFFNUM)) N P S P(1)=DIEFFDNM,P("FILE")=DIEFF D BLD^DIALOG(505,.P,.P) S DIEFFNUM=0
 N P S P("FILE")=DIEFF,P(1)=DIEFFDNM D BLD^DIALOG(501,.P,.P)
 Q 0
 ;
ADDCONV(DIEFIEN,DIEFADAR) ;
 N I,DIEFNIEN,P
 F I=1:1:$L(DIEFIEN,",")-1 D
 . S P=$P(DIEFIEN,",",I)
 . I P,$E(P)'="+" Q
 . S DIEFNIEN=@DIEFADAR@($TR(P,"+?"))
 . S $P(DIEFIEN,",",I)=DIEFNIEN
 Q DIEFIEN
 ;
PUTDATA ;CODE TO ACTUALLY PUT THE DATA INTO THE NODE BEING EDITED. ALSO SAVES ORIGINAL VALUES. CALLED FROM DIEF.
 I +DIEFSPOT D
 . I DIEFNVAL[U D  Q
 . . S DIEFNG=1
 . . N INT,EXT
 . . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD
 . . D BLD^DIALOG(714,.INT,.EXT)
 . S DIEFOVAL=$P(DIEFFVAL,"^",DIEFSPOT)
 . S $P(DIEFFVAL,"^",DIEFSPOT)=DIEFNVAL,DOREPL=1
 E  I $E(DIEFSPOT)="E" D
 . N FR,TO,OLEN,NLEN
 . S FR=$P($P(DIEFSPOT,"E",2),",",1),TO=$P(DIEFSPOT,",",2)
 . S NLEN=$L(DIEFNVAL)
 . I NLEN-1>(TO-FR) D  Q
 . . S DIEFNG=1
 . . N INT,EXT
 . . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD
 . . D BLD^DIALOG(716,.INT,.EXT)
 . S DIEFOVAL=$E(DIEFFVAL,FR,TO),OLEN=$L(DIEFOVAL)
 . I $E(DIEFFVAL,TO+1,999)="" S $E(DIEFFVAL,FR,TO)=DIEFNVAL
 . E  S $E(DIEFFVAL,FR,TO)=DIEFNVAL_$J("",$S(OLEN>NLEN:OLEN-NLEN,1:0))
 . S DOREPL=1
 E  I DIEFSPOT=0 D
 . I $P($G(^DD(+$P(^DD(DIEFF,DIEFFLD,0),U,2),.01,0)),U,2)["W" D
 . . I '$$VROOT^DIEFU(DIEFNVAL) Q
 . . D PUTWP^DIEFW(DIEFFLAG,DIEFNVAL,DIEFNODE)
 . E  D
 . . N INT,EXT
 . . S (INT(1),EXT(1))="MULTIPLE",EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD
 . . D BLD^DIALOG(520,.INT,.EXT)
 . . S DIEFNG=1
 E  I DIEFSPOT=" " D
 . N INT,EXT
 . S (INT(1),EXT(1))="COMPUTED",EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD
 . D BLD^DIALOG(520,.INT,.EXT)
 . S DIEFNG=1
 Q
 ;

DIEFU
DIEFU ;SF/DPC-FILER UTILITIES ;11/25/94  11:24
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
INIZE ;
 N %,X,%H,DIE,DICS,DIC,%DT,DIK,%Y,%X,%D,%M,%I
 D DT^DICRW
 D CLEAN
 Q
CLEAN ;
 K DIRUT,DIROUT,DUOUT,DTOUT
 K ^TMP("DIERR",$J),^TMP("DIMSG",$J),^TMP("DIHELP",$J)
 K DIERR,DIHELP,DIMSG
 Q
 ;
CALLOUT(DIOUTAR) ;
 I '$$VROOT(DIOUTAR) Q
 I $D(DIERR) D
 . S @DIOUTAR@("DIERR")=DIERR
 . M @DIOUTAR@("DIERR")=^TMP("DIERR",$J)
 . K ^TMP("DIERR",$J)
 . Q
 I $D(DIHELP) D
 . S @DIOUTAR@("DIHELP")=DIHELP
 . M @DIOUTAR@("DIHELP")=^TMP("DIHELP",$J)
 . K ^TMP("DIHELP",$J)
 . Q
 I $D(DIMSG) D
 . S @DIOUTAR@("DIMSG")=DIMSG
 . M @DIOUTAR@("DIMSG")=^TMP("DIMSG",$J)
 . K ^TMP("DIMSG",$J)
 . Q
 Q
 ;
IEN(DIEFDA) ;
IENX ;
 I '$D(DIEFDA) Q 0
 N I,DIEFIEN S (I,DIEFIEN)="",DIEFDA(0)=$G(DIEFDA)
 F  S I=$O(DIEFDA(I)) Q:I=""  S DIEFIEN=DIEFIEN_DIEFDA(I)_","
 K DIEFDA(0)
 Q DIEFIEN
 ;
DA(DAIEN,DATARG) ;
DAX ;
 K DATARG N I
 F I=1:1:$L(DAIEN,",")-1 S DATARG(I-1)=$P(DAIEN,",",I)
 I $D(DATARG(0)) S DATARG=DATARG(0) K DATARG(0)
 Q
 ;
VROOT(DIEFAR) ;
 I DIEFAR'["(" Q 1
 I $E(DIEFAR,$L(DIEFAR))=")",$F(DIEFAR,")")>($F(DIEFAR,"(")+1) Q 1
 D BLD^DIALOG(202,"array root")
 Q 0
 ;
VFILE(F,FLAG) ;
VFILEX ;
 I $P($G(^DD(F,.01,0)),U,2)]"",$P(^(0),U,2)'["W" Q 1
 I $G(FLAG)["D" N P S P("FILE")=F D BLD^DIALOG(401,.P,.P)
 Q 0
 ;
VENTRY(DIEFF,DIEFIEN,DIEFFLG) ;
 N DIEFROOT,DIEFDA
 S DIEFFLG=$G(DIEFFLG),DIEFDA=$P(DIEFIEN,",")
 S DIEFROOT=$$ROOT^DIQGU(DIEFF,DIEFIEN,1,$S(DIEFFLG["D":1,1:0)) Q:DIEFROOT="" 0
 I $P($G(@DIEFROOT@(DIEFDA,0)),"^",1)="" D  Q 0
 . I DIEFFLG["D" N DIEFP S DIEFP("FILE")=DIEFF,DIEFP("IENS")=DIEFIEN D BLD^DIALOG(601,"",.DIEFP)
 I DIEFFLG["9" Q:'$$VMINUS9(DIEFF,DIEFIEN,DIEFFLG) 0
 Q 1
 ;
VMINUS9(DIEFF,DIEFIEN,DIEFFLG) ;
 N DIEFTOP,DIEFROOT S DIEFFLG=$G(DIEFFLG)
 S DIEFTOP=$P(DIEFIEN,",",$L(DIEFIEN,",")-1),DIEFROOT=$$ROOT^DIQGU($$FNO^DILIBF(DIEFF),.DIEFTOP,1,$S(DIEFFLG["D":1,1:0))
 Q:DIEFROOT="" 0
 I $D(@DIEFROOT@(DIEFTOP,-9)) D  Q 0
 . I DIEFFLG["D" N DIEFP S DIEFP("FILE")=DIEFF,DIEFP("IENS")=DIEFIEN D BLD^DIALOG(602,"",.DIEFP)
 Q 1
 ;
CHKFLD(DIEFF,DIEFFLD) ;
 I DIEFFLD'=+DIEFFLD S DIEFFLD=$$FLDNUM^DIEF1(DIEFF,DIEFFLD) Q:'DIEFFLD 0
 I '$$VFIELD(DIEFF,DIEFFLD,"D") Q 0
 Q DIEFFLD
 ;
VFIELD(F,FLD,FLAG) ;
VFIELDX ;
 I $D(^DD(F,FLD)) Q 1
 I $G(FLAG)["D" N P S (P(1),P("FIELD"))=FLD,P("FILE")=F D BLD^DIALOG(501,.P,.P)
 Q 0
 ;
DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ;
DTX ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE
 N %DT,X,Y
 S DIEFDT=$G(DIEFDT)
 I $G(DIEFX)="" D BLD^DIALOG(202,"date being converted") G DTOUT
 I '$$VERFLG^DIEFU(DIEFDT,"FNPRSTXEe") G DTOUT
 I DIEFX?."?" D DT^DIEH1(DIEFDT) S DIEFY=-1 G DTOUT
 S %DT=DIEFDT,X=DIEFX S:$G(DIEFDT0)]"" %DT(0)=DIEFDT0 D ^%DT S DIEFY=Y
 I DIEFY=-1 D:DIEFDT'["e"  G DTOUT
 . N DIEFP
 . S DIEFP(1)=DIEFX,DIEFP(2)="date/time"
 . D BLD^DIALOG(330,.DIEFP,.DIEFP)
 I DIEFDT["E" D DD^%DT S DIEFY(0)=Y
DTOUT I $G(DIOUTAR)]"" D CALLOUT^DIEFU(DIOUTAR)
 Q
 ;
VERFLG(FLG,GDFLGS) ;
 N EI
 S EI=$TR(FLG,GDFLGS,"")
 I EI="" Q 1
 D BLD^DIALOG(301,EI,EI)
 Q 0
 ;
XA(DIEFF,DIEFIEN,DIEFFLD,DIEFNVAL,DIEFOVAL) ;
 N DA
 S DIEFNVAL=$G(DIEFNVAL),DIEFOVAL=$G(DIEFOVAL)
 Q:DIEFNVAL=DIEFOVAL
 D DA(DIEFIEN,.DA)
 D XRFAUD^DIEF
 Q
 ;
FILENM(F) ;
 N NM
 S NM=$P($G(^DIC($$FNO^DILIBF(F),0)),U)
 ;I NM="" <DO ERROR>
 Q NM
 ;
FLDNM(F,FLD) ;
 N NM,UP
 S NM=$P($G(^DD(F,FLD,0)),U,1)
 F  S UP=$G(^DD(F,0,"UP")) Q:'UP  D
 . S NM=NM_" in "_$P($G(^DD(F,0)),U,1)
 . S F=UP
 . Q
 ;I NM="" <DO ERROR>
 Q NM

DIEFW
DIEFW ;SFISC/DPC-FILER WP ;7/29/94  15:37
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;
WPX ;
 S DIEFWPFL=$G(DIEFWPFL)
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 I DIEFIEN']"" D BLD^DIALOG(202,"IENS","IENS") G OUT
 I '$$VERFLG^DIEFU(DIEFWPFL,"AZK") G OUT
 I "@"'[DIEFTSRC I '$$VROOT^DIEFU(DIEFTSRC) G OUT
 I '$$VFILE^DIEFU(DIEFF,"D") G OUT
 I '$$VFIELD^DIEFU(DIEFF,DIEFFLD,"D") G OUT
 I $P($G(^DD(+$P(^DD(DIEFF,DIEFFLD,0),U,2),.01,0)),U,2)'["W" N EI S EI("FILE")=DIEFF,EI("FIELD")=DIEFFLD D BLD^DIALOG(726,.EI,.EI) G OUT
 I '$$VENTRY^DIEFU(DIEFF,DIEFIEN,"D") G OUT
 N DIEFNODE,DIEFSPOT S DIEFSPOT=" " D GLRF^DIOU(DIEFF,DIEFFLD,.DIEFNODE,.DIEFSPOT)
 N DEPTH,I,D
 S DEPTH=$L(DIEFIEN,",")-1
 F I=DEPTH:-1:1 S D="D"_(DEPTH-I) N @D S @D=$P(DIEFIEN,",",I)
 K DEPTH,D,I
 I DIEFWPFL["K" N DIEFLOCK D  G:'$D(DIEFLOCK) OUT
 . S DIEFLOCK=DIEFNODE
 . L +@DIEFLOCK:1 E  D
 . . K DIEFLOCK
 . . N EXT S EXT("FILE")=DIEFF,EXT("IENS")=DIEFIEN D BLD^DIALOG(110,"",.EXT)
 D PUTWP(DIEFWPFL,DIEFTSRC,DIEFNODE)
 I $D(DIEFLOCK) L -@DIEFLOCK
OUT I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT)
 Q
 ;
PUTWP(DIEFWPFL,DIEFTSRC,DIEFNODE) ;
 N BEGIN
 I "@"[DIEFTSRC K @DIEFNODE Q
 I '($D(@DIEFTSRC)\10) D BLD^DIALOG(305,DIEFTSRC,DIEFTSRC) Q
 I $G(DIEFWPFL)'["A" S BEGIN=1 K @DIEFNODE
 E  S BEGIN=$$NUMLNS(DIEFNODE)+1 K:BEGIN=1 @DIEFNODE
 I $D(@DIEFTSRC@($O(@DIEFTSRC@(0)),0))#2 S DIEFWPFL=$G(DIEFWPFL)_"Z"
 N LINECNT,INLINE S INLINE=0
 F LINECNT=BEGIN:1 S INLINE=$O(@DIEFTSRC@(INLINE)) Q:INLINE=""  D
 . I $G(DIEFWPFL)'["Z" S @DIEFNODE@(LINECNT,0)=@DIEFTSRC@(INLINE)
 . E  S @DIEFNODE@(LINECNT,0)=$G(@DIEFTSRC@(INLINE,0))
 S LINECNT=LINECNT-1
 S @DIEFNODE@(0)=U_U_LINECNT_U_LINECNT_U_DT
 Q
 ;
NUMLNS(DIWPROOT) ;
 N DIWPLN
 S DIWPLN=$P($G(@DIWPROOT@(0)),U,3)
 Q:DIWPLN DIWPLN
 S DIWPLN=$O(@DIWPROOT@(""),-1)
 Q +DIWPLN

DIEH
DIEH ;SFISC/DPC-HELP ;11/9/94  14:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
GET(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
GETX ;
 N DIEHZ,DIEHD,DIEHEXIT,DIEHPF,DIEHUFLG
 S DIEHUFLG=$G(DIEHFLG)
 I '$G(DIQUIET) N DIQUIET S DIQUIET=1
 I '$G(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 I $G(DIEHIEN)]"" N DA,C,D,I D DA^DIEFU(DIEHIEN,.DA) S C=$L(DIEHIEN,",")-1 F I=1:1:C S D="D"_(C-I) N @D S @D=$P(DIEHIEN,",",I)
 S DIEHZ=$$ZERO(DIEHF,DIEHFLD) I DIEHZ=0 G GETOUT
 S DIEHD=$P(DIEHZ,U,2)
 D BLDFLGS G:$G(DIEHEXIT) GETOUT
 I DIEHD["P" S DIEHPF=+$P(DIEHD,"P",2)
 S DIHELP=+$O(^TMP("DIHELP",$J,""),-1)
 I DIEHUFLG["F",DIEHFLD=.01 D PXREFS(DIEHF,DIEHFLD)
 I DIEHUFLG["H" D HPROMPT(DIEHF,DIEHFLD)
 I DIEHUFLG["X" D XHLP(DIEHF,DIEHFLD)
 I DIEHUFLG["D" D DESCR(DIEHF,DIEHFLD)
 I DIEHUFLG["P" D SCRNDES(DIEHF,DIEHFLD)
 I DIEHUFLG["C" D SCRNDES(DIEHF,DIEHFLD)
 I DIEHUFLG["T" N DIEHDT S DIEHDT=$P($P($P(DIEHZ,U,5,99),"%DT=""",2),"""",1)  D DT^DIEH1(DIEHDT)
 I DIEHUFLG["S" D SCRNCD(DIEHF,DIEHFLD,DIEHZ)
 I DIEHUFLG["U" D UNSCRNCD(DIEHZ)
 I DIEHUFLG["V" D VPMSG(DIEHF,DIEHFLD)
 I DIEHUFLG["B",DIEHUFLG'["b" D BLD^DIALOG(9115)
 I DIEHUFLG["M" D BLD^DIALOG(9116)
 I DIEHUFLG["G",DIEHFLG'["g",$G(DIEHPF) D FOLLOW(DIEHPF,DIEHFLG)
 I '$G(DIHELP) K DIHELP
GETOUT I $D(DIEHOUT) D CALLOUT^DIEFU(DIEHOUT)
 Q
 ;
BLDFLGS ;
 N A1,A2,C1,C2,DIEHGFLG
 S C1="HX",C2="XD",(A1,A2)=""
 I DIEHD S DIEHF=+DIEHD,DIEHFLD=.01,DIEHD=$P(^DD(DIEHF,.01,0),U,2)
 I DIEHD["W" S (A1,A2)="HD"
 E  I DIEHD["D" S (A1,A2)="T"
 E  I DIEHD["S" S A1="CS",A2="S",DIEHGFLG="U"
 E  I DIEHD["P" S A1="PG",A2="G",DIEHGFLG="F"
 E  I DIEHD="V" S A1="VB",A2="VMB"
 I DIEHFLD=.01,'$D(^DD(DIEHF,0,"UP")) S A1=A1_"F",A2=A2_"F"
 I DIEHUFLG'["r",'$$VERFLG^DIEFU(DIEHUFLG,"bgA?"_C1_C2_A1_A2_$G(DIEHGFLG)) S DIEHEXIT=1
 I DIEHUFLG["??" S DIEHUFLG=DIEHUFLG_C2_A2
 E  I DIEHUFLG["?" S DIEHUFLG=DIEHUFLG_C1_A1
 E  I DIEHUFLG["A" S DIEHUFLG=$TR(C1_C2_A1_A2,"S","U")
 Q
 ;
ZERO(F,D) ;
 I '$$VFILE^DIEFU(F,"D") Q 0
 I '$$VFIELD^DIEFU(F,D,"D") Q 0
 Q ^DD(F,D,0)
 ;
BN ;Insert blank node.
 S:DIHELP DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=""
 Q
 ;
HPROMPT(F,D) ;
 N T
 S T=$G(^DD(F,D,3))
 I $L(T) D
 . D BN
 . S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T
 Q
 ;
XHLP(DIEHF,DIEHFLD) ;
 ;DA() and D0,D1,etc. passed thru symbol table.
 N DIEHXH S DIEHXH=$G(^DD(DIEHF,DIEHFLD,4))
 I $L(DIEHXH) D
 . D BN
 . N DIEHECNT S DIEHECNT=$G(DIERR)
 . N DDIOLFLG S DDIOLFLG="H" X DIEHXH
 . I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(DIEHF,"",DIEHFLD,"Xecutable Help")
 Q
 ;
DESCR(F,D) ;
 N L
 S L=$P($G(^DD(F,D,21,0)),U,3)
 I L D
 . D BN
 . N I F I=1:1:L S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=^DD(F,D,21,I,0)
 . Q
 Q
 ;
PXREFS(DIEHF,DIEHFLD) ;
 N DIF,DIFD,DIEHROOT,DIEHIXID,DIEHIXP,DIEHIXNM,DIFULL
 S DIEHIXP=$$FILENM^DIEFU(DIEHF)_" "
 D GETIXNM(DIEHF,.DIEHIXNM)
 S DIF=""
 F  S DIF=$O(DIEHIXNM(DIF)) Q:DIF=""  D  Q:$D(DIFULL)
 . S DIFD=""
 . F  S DIFD=$O(DIEHIXNM(DIF,DIFD)) Q:DIFD=""  D  Q:$D(DIFULL)
 . . I $L(DIEHIXP)+$L(DIEHIXNM(DIF,DIFD))>240 D  Q
 . . . S DIEHIXP=DIEHIXP_", etc     "
 . . . S DIFULL=1
 . . S DIEHIXP=DIEHIXP_DIEHIXNM(DIF,DIFD)_", or "
 S DIEHIXP=$E(DIEHIXP,1,$L(DIEHIXP)-5)
 D BLD^DIALOG(9105,DIEHIXP)
 Q
 ;
GETIXNM(DIEHF,DIEHIXNM) ;
 S DIEHROOT=$$ROOT^DIQGU(DIEHF,"",1)
 S DIEHIXID="Az"
 F  S DIEHIXID=$O(@DIEHROOT@(DIEHIXID)) Q:DIEHIXID=""  D
 . N DIEHIXF,DIEHIXFD
 . S DIEHIXF=$O(^DD(DIEHF,0,"IX",DIEHIXID,"")) Q:DIEHIXF=""
 . S DIEHIXFD=$O(^DD(DIEHF,0,"IX",DIEHIXID,DIEHIXF,"")) Q:DIEHIXFD=""
 . S DIEHIXNM(DIEHIXF,DIEHIXFD)=$$FLDNM^DIEFU(DIEHIXF,DIEHIXFD)
 Q
 ;
SCRNDES(F,D) ;
 N T
 S T=$G(^DD(F,D,12))
 I $L(T) D
 . D BN
 . S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T
 . Q
 Q
 ;
SCRNCD(F,D,DIEHZ) ;
 N S,DIC,Y,A,T,I
 I $P(DIEHZ,U,2)'["*" D UNSCRNCD(DIEHZ) Q
 S S=$G(^DD(F,D,12.1))
 I S="" D UNSCRNCD(DIEHZ) Q
 D CODES
 I $D(Y) D
 . N DIEHECNT S DIEHECNT=$G(DIERR)
 . X S
 . D BLD^DIALOG(9101)
 . F I=1:1:T D
 . . S Y=$P(Y(I),";",1)
 . . X DIC("S") I  D CODESOUT
 . I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(F,"",D,"set of codes screen")
 Q
UNSCRNCD(DIEHZ) ;
 N Y,A,T,I
 D CODES
 I $D(Y) D
 . D BLD^DIALOG(9101)
 . F I=1:1:T D CODESOUT
 . Q
 Q
 ;
CODES ;
 S A=$P(DIEHZ,U,3)
 I A]"" D
 . S T=$L(A,";")-1
 . F I=1:1:T S Y(I)=$P(A,";",I)
 . Q
 Q
 ;
CODESOUT ;
 S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=$P(Y(I),":",1)_"        "_$P(Y(I),":",2)
 Q
 ;
VPMSG(F,D) ;
 N I,N,P,L
 D BLD^DIALOG(9103)
 S I=0 F  S I=$O(^DD(F,D,"V",I)) Q:I="B"  S N=^(I,0) D
 . S P(1)=$P(N,U,4),P(2)=$P(N,U,2),L=$S(I=1:"",1:"S")
 . D BLD^DIALOG(9117,.P,.P,"",L)
 . Q
 Q
 ;
FOLLOW(DIEHPF,DIEHUFLG) ;
 D GET(DIEHPF,"",.01,DIEHUFLG_"r")
 Q

DIEH1
DIEH1 ;SFISC/DPC-DBS HELP CON'T ;10/19/94  13:07
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;;
DT(DIEHDT) ;
 N P,Q
 I DIEHDT'["N" S P(1)="or 012057"
 S P(2)=$S(DIEHDT["P":"assumes a date in the PAST",DIEHDT["F":"assumes a date in the FUTURE",1:"uses the CURRENT YEAR")
 I DIEHDT'["X" S P(3)="You may omit the precise day, as:  JAN, 1957."
 D BLD^DIALOG(9110,.P,.P)
 I DIEHDT["T"!(DIEHDT["R") D
 . I DIEHDT["S" S Q(1)="Seconds may be entered as 10:30:30 or 103030AM."
 . I DIEHDT["R" S Q(2)="Time is REQUIRED for this response."
 . D BLD^DIALOG(9111,.Q,.Q)
 . Q
 Q
 ;

DIENV
DIENV ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE;7/26/96  10:59
 ;;21.0;VA FileMan;**12**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified
 ;
 S XPDNOQUE=1 ;prevents QUEUEING of a FM patch install
 Q

DIEQ
DIEQ ;SFISC/XAK,YJK-HELP DURING INPUT ;4/14/95  10:10
 ;;21.0;VA FileMan;**3**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BN S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD
 S DZ=X D EN1 G B^DIED
QQ ;
 I DV,DV["*",$D(^DD(+DV,.01,0)) S DQ(DQ)=$P(DQ(DQ),U,1,4)_U_$P(^(0),U,5,99)
EN1 S DDH=0 G M:DV I DP<0 D HP G P
 I X="?"!(X["BAD") F DG=3,12 Q:DG=12&($G(DISORT))  I $D(^DD(DP,D,DG)) S X=^(DG),A1="T" D N
 D H G:'$D(DZ) Q
 ;
P I DV["P" K DO S DIC=U_DU,D="B",DIC(0)="M"_$E("L",DV'["'") G AST:DV["*"&('$G(DISORT)) D DQ^DICQ D %
VP I DV["V" S DU=DP S:DV DU=+DO(2),D=.01 D V G Q
D I DV["D" S %(0)=0,%DT=$P($P($P(DQ(DQ),U,5,9),"%DT=""",2),"""",1) D HELP^%DTC
S I DV["S" X:($D(^DD(DP,D,12.1))#2)&('$G(DISORT)) ^(12.1) S A1="T",DST=$$EZBLD^DIALOG(8068)_" " D DS,S1
Q K DST,A1 S:$D(DIE) DIC=DIE S D=0 I $D(DDH)>10 D LIST^DDSU
 Q
 ;
 ;
S1 F DG=1:1 S Y=$P($P(DQ(DQ),U,3),";",DG) Q:Y=""  S D=$P(Y,":",2),Y=$P(Y,":",1) X:$D(DIC("S")) DIC("S") I  S A2="",$P(A2," ",15-($L(Y)+7))=" ",DST="  "_Y_A2_" "_D D DS
 K A1,A2 Q
 ;
N F  Q:X=""  F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<75 S DST=$P(X," ",1,%) D DS D:X'="" N1 Q
 S X=DZ
 Q
 ;
N1 S X=$P(X," ",%+1,$L(X," ")) Q
 ;
DS S:'$D(A1) A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=$S(A1="X":"",1:"     ")_DST K A1,DST Q
 ;
HP I $D(DQ(DQ,3)) S A1="T",DST=DQ(DQ,3) D DS
 I $D(DQ(DQ,4)) S A1="X",DST=DQ(DQ,4) D DS
 Q
 ;
% S %=$G(DIC("V")) K DIC S:%]"" DIC("V")=% Q
 ;
AST S:$D(X)[0 X="?" X $P(DQ(DQ),U,5,99) K DIC G Q
 D ^DIC K DIC,DICS,DICW G Q
 ;
M K DO S DZ=X,DIC=DIE_DA_","_$S(+$P(DC,U,3)=$P(DC,U,3):$P(DC,U,3),1:$C(34)_$P(DC,U,3)_$C(34))_",",D="B",DIC(0)="LM",DZ(1)=0
 I '$D(@(DIC_"0)")) S DO=U_$P(DC,U,2) D DO2^DIC1
 D DQ^DICQ D % G Q:'$D(DZ)!(DV["S") S X=DZ G P
 ;
H I '$G(DISORT),$D(^DD(DP,D,4)) S A1="X",DST=^(4) D DS,LIST^DDSU Q:'$D(DZ)
 I $D(X),X'["BAD",X?1"??".E D
 . N DIDG,DG
 . S DIDG=$P($G(^DD(DP,D,21,0)),U,3)
 . K DDSQ
 . F DG=1:1 Q:'$D(^DD(DP,D,21,DG,0))  Q:+DIDG&(DG>DIDG)  D:$G(DDH)'<15 LIST^DDSU Q:$D(DDSQ)  S DST=^DD(DP,D,21,DG,0) D DS
 . I $D(DDSQ) K DDSQ,DDH
 Q
 ;
BK S DDH=$G(DDH)+1,DDH(DDH,"T")=" " Q
 ;
V S DDH=+$G(DDH),A1="T",DST=$$EZBLD^DIALOG(8071) D DS
 F Y=0:0 S Y=$O(^DD(DU,D,"V",Y)) Q:Y'>0  I $D(^(Y,0)) S Y(0)=^(0) X:$D(DIC("V")) DIC("V") I  I $D(^DIC(+Y(0),0)) S Y(1)=$P(Y(0),U,4),Y(2)=$P(Y(0),U,2),DST=$$EZBLD^DIALOG(8072,.Y) K Y(1),Y(2) D DS
 D BK S DST=$$EZBLD^DIALOG(8073) D DS S DU="" D BK I DZ'?1"??".E K X,DZ Q
 D T^DIEQ1 K X,DZ Q
 ;
 ;#8071  Enter one of the following
 ;#8072  |Prefix|.EntryName to select a |filename|
 ;#8073  To see the entries in any particular file type <Prefix.?>

DIEQ1
DIEQ1 ;SFISC/XAK,YJK-HELP WRITE ;5/27/94  7:29 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
T S A1="T" F DG=2:1 S X=$T(T+DG) Q:X=""  S DST=$E(X,4,99) D DS^DIEQ
 K A1,DST Q
 ;;If you simply enter a name then the system will search each of
 ;;the above files for the name you have entered. If a match is
 ;;found the system will ask you if it is the entry that you desire.
 ;;
 ;;However, if you know the file the entry should be in, then you can
 ;;speed processing by using the following syntax to select an entry:
 ;;      <Prefix>.<entry name>
 ;;                or
 ;;      <Message>.<entry name>
 ;;                or
 ;;      <File Name>.<entry name>
 ;;
 ;;Also, you do NOT need to enter the entire file name or message
 ;;to direct the look up. Using the first few characters will suffice.

DIET
DIET ;SFISC/XAK-DISPLAY INPUT TEMPLATE ;8/16/95  15:22
 ;;21.0;VA FileMan;**12**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I '$D(^DIE(D0,0)) S X="" Q
 S X=^(0),DL=1,DIFILE(DL)=$P(X,U,4),W="FIRST" G Q:'$D(^DD(DIFILE(DL),0))
A S DIPP(DL)=$S($D(^DIE(D0,"DR",DL,DIFILE(DL))):^(DIFILE(DL)),1:"ALL") F %A(DL)=1:1 S X=$P(DIPP(DL),";",%A(DL)) Q:X=""  D DJ
 S %(DL)=0 F  S %(DL)=$O(^DIE(D0,"DR",DL,DIFILE(DL),%(DL))) S:%(DL)="" %(DL)=-1 G UP:%(DL)'>0 S DIPP(DL)=^(%(DL)) F %A(DL)=1:1 S X=$P(DIPP(DL),";",%A(DL)) Q:X=""  D DJ
EXIT K DIFILE,DIPP,%A,% S X="" Q
 ;
DJ S Y=+$P(X,":",1),Z=+$P(X,":",2) I Y,Z S X=Y-.00000001 F  S X=$O(^DD(DIFILE(DL),X)) S:X="" X=-1 Q:X=Z  G Q:X'>0 S %B=X,X=$P(^(X,0),U,1),Y="" D W S X=%B
 I $L(X)<30 S Y=$S($D(^DD(DIFILE(DL),X,0)):^(0),1:""),X=$S(Y]"":$P(Y,U,1),1:X)
W W !?DL*2-2,W," EDIT FIELD: ",X,"//" S W="THEN" Q:'$P(Y,U,2)  S DL=DL+1,DIFILE(DL)=+$P(Y,U,2),%(DL)=0 D A Q
Q Q
 ;
UP S DL=DL-1 G EXIT:'DL Q
 ;
AUD N DP,%,%D,%F,%T,C,DPS,DIEDA,DIEF,DIEX,DIIX,DIANUM,Y
 S DIIX="3^.01^A",DP=+DO(2) D AUDIT:DP>0 Q
AUDIT ;
 I $D(^DD(DP,+$P(DIIX,U,2),"AX")) X ^("AX") Q:'$T
 K % S DIEX=X D @+DIIX
 K DPS,DIEX,DIEDA,DIEF,%T,DIIX,%F,%D,%
 Q
3 ;
 I $D(DG),DG]"",$D(DIANUM(DG)) S Y=X,(DIEX(1),C)=$P(^DD(DP,+$P(DIIX,U,2),0),U,2) D Y^DIQ S @(DIANUM(DG)_"+DIIX)")=Y K DIANUM(DG) G I
2 ;
 S:$D(DP(1)) DPS=DP(1) S DIEDA="",DIEF="",%=1,DP(1)=DP,%F=+DP,X=DA
 F C=1:1 Q:'$D(^DD(DP(1),0,"UP"))  S %F=^("UP"),%=$O(^DD(%F,"SB",DP(1),0)) S:%="" %=-1 S DIEDA=DA(C)_","_DIEDA,DIEF=%_","_DIEF,DP(1)=%F
 D ADD I $D(DG),DG]"" S DIANUM(DG)="^DIA("_%F_","_+Y_","
 S (DIEX(1),C)=$P(^DD(DP,+$P(DIIX,U,2),0),U,2),Y=DIEX D Y^DIQ
 S ^DIA(%F,"B",DIEDA_DA,%D)="",X=DIEX S:$D(DPS) DP(1)=DPS
 S ^DIA(%F,%D,0)=DIEDA_DA_U_%T_U_DIEF_+$P(DIIX,U,2)_U_DUZ_U_$P(DIIX,U,3),^(+DIIX)=Y
I I DIEX(1)["P"!(DIEX(1)["V")!(DIEX(1)["S") S ^(DIIX+.1)=X_U_DIEX(1)
 Q
ADD I '$D(^DIA(%F,0)) S ^DIA(%F,0)=$P(^DIC(%F,0),U,1)_" AUDIT^1.1I"
 F Y=$P(^(0),U,3):1 I '$D(^(Y)) L +^DIA(%F,Y):0 Q:$T
 S $P(^(0),U,3,4)=Y_U_($P(^(0),U,4)+1),^(Y,0)=X L -^DIA(%F,Y)
 S %D=Y,%T=$P($H,",",2),%T=%T#60/100+(%T#3600\60)/100+(%T\3600)/100,%T=DT_%T
 S ^DIA(%F,"C",%T,Y)="",^DIA(%F,"D",DUZ,Y)=""
 Q

DIEV
DIEV ;SFISC/DPC-DATA VALIDATOR ;11/28/94  13:48
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ;
VALX ;
 N DIEV0,DIEVP2,DA,D,I,C K DIEVANS
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 S DIEVFLG=$G(DIEVFLG) I '$$VERFLG^DIEFU(DIEVFLG,"HFERY") G OUT
 D FLDVAL G:$G(DIEVAL)=U OUT
 D DA^DIEFU(DIEVIEN,.DA)
 S C=$L(DIEVIEN,",")-1 F I=1:1:C S D="D"_(C-I) N @D S @D=$P(DIEVIEN,",",I)
 D AUXVAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,.DIEVANS,.DIEV0,.DIEVP2)
 I $G(DIEVANS)=U!("@"[DIEVAL) G OUT
MINVAL ;
 D INT(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,.DIEVANS,$G(DIEV0),$G(DIEVP2))
 I DIEVANS=U D ERR
OUT S DIEVANS=$G(DIEVANS,U)
 I DIEVFLG["F",DIEVANS'=U D FDA
 I $G(DIOUTAR)]"" D CALLOUT^DIEFU(DIOUTAR)
 Q
 ;
FLDVAL ;
 N DIEVOUT S DIEVOUT=0
 I '$$VFILE^DIEFU(DIEVF,"D") S DIEVAL=U Q
 I '$$VFIELD^DIEFU(DIEVF,DIEVFLD,"D") S DIEVAL=U Q
 S DIEV0=^DD(DIEVF,DIEVFLD,0),DIEVP2=$P(DIEV0,U,2)
 D DTYPE
 I DIEVOUT=1 S DIEVAL=U
 Q
 ;
AUXVAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEV0,DIEVP2) ;
 N DIEVOUT S DIEVOUT=0
 I '$D(DIOVRD),$P($G(^DD($$FNO^DILIBF(DIEVF),0,"DI")),U,2)="Y",DIEVFLG'["Y" D  G AUXERR
 . N INT,EXT S INT(1)=$$FILENM^DIEFU(DIEVF),EXT("FILE")=DIEVF
 . D BLD^DIALOG(405,.INT,.EXT)
 I $P(DIEV0,U,5,99)["DINUM","@"'[DIEVAL D  G AUXERR
 . N EXT,INT S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD,(INT(1),EXT(1))="DINUMed"
 . D BLD^DIALOG(520,.INT,.EXT)
 I $E(DIEVAL)="?"!(DIEVP2["V"&(DIEVAL[".?")) N P S P(1)=DIEVF,P(2)=DIEVFLD D BLD^DIALOG(1610,"",.P) G AUXERR
 I DIEVFLG["R" G:'$$VENTRY^DIEFU(DIEVF,DIEVIEN,"D9") AUXERR
 I DIEVP2["I",$$DATA(DIEVF,DIEVFLD) N P S P("FIELD")=DIEVFLD,P("FILE")=DIEVF D BLD^DIALOG(710,.P,.P) G AUXERR
 I "@"[DIEVAL D DELETE G:DIEVOUT AUXERR Q
 I DIEVFLG["I" D
 . S DIEVANS=DIEVAL
 . I DIEVFLG["E" S DIEVANS(0)=$$EXTERNAL^DIQGU(DIEVF,DIEVFLD,"",DIEVAL)
 Q
AUXERR S DIEVANS=U
 Q
 ;
DTYPE ;
 I DIEVP2 D  S DIEVOUT=1 Q
 . N T,INT,EXT D DTYP^DIOU(DIEVF,DIEVFLD,.T)
 . I T=5 S INT(1)="word-processing",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT) Q
 . S INT(1)="multi-valued",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT)
 I DIEVP2["C" N INT,EXT S INT(1)="computed",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT) S DIEVOUT=1 Q
 Q
 ;
DELETE ;
 I $D(^DD(DIEVF,DIEVFLD,"DEL")) D
 . N DIEVECNT S DIEVECNT=$G(DIERR)
 . N I S I="" F  S I=$O(^DD(DIEVF,DIEVFLD,"DEL",I)) Q:I=""  X $G(^(I,0)) I  S DIEVOUT=1
 . I DIEVECNT'=$G(DIERR) S DIEVOUT=1 D HKERR^DILIBF(DIEVF,$G(DIEVIEN),DIEVFLD,"DEL node")
 I DIEVP2["R" D
 . I DIEVFLD'=.01 S DIEVOUT=1 Q
 . I '$D(^DD(DIEVF,0,"UP")) Q
 . I $P($G(@$$ROOT^DILFD(DIEVF,DIEVIEN,1)@(0)),U,4)=1 S DIEVOUT=1
 I 'DIEVOUT S DIEVANS="" S:DIEVFLG["E" DIEVANS(0)=""
 E  D
 . N INT,EXT
 . S INT(1)=$$FLDNM^DIEFU(DIEVF,DIEVFLD),INT(2)=$$FILENM^DIEFU(DIEVF)
 . S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD
 . D BLD^DIALOG(712,.INT,.EXT)
 Q
 ;
DATA(DIEVF,DIEVFLD) ;
 N DIEVNODE,DIEVSPOT,N S DIEVSPOT=" ",N=0
 D GLRF^DIOU(DIEVF,DIEVFLD,.DIEVNODE,.DIEVSPOT)
 I +DIEVSPOT D
 . I $P($G(@DIEVNODE),U,DIEVSPOT)'="" S N=1
 E  I $E(DIEVSPOT)="E" D
 . N F,T
 . S F=$P($P(DIEVSPOT,"E",2),",",1),T=$P(DIEVSPOT,",",2)
 . I $TR($E($G(@DIEVNODE),F,T)," ")'="" S N=1
 Q N
 ;
INT(%B1,%B2,DIEVFLG,X,DIEVANS,%B3,%B) ;
 N %A,%E,%C,DIR,DIC,Y,DIE,%J,%T,%BA,DP,DIFLD,DDH,%BU,%I,%K,DQ,DIFILE,C,DIEVECNT
 I $G(%B3)="" S %B3=^DD(%B1,%B2,0),%B=$P(%B3,U,2)
 I %B["V" D VP^DIEV1(%B1,%B2,DIEVFLG,X,%B3,.DIEVANS) Q
 I %B["N" D  Q:$G(DIEVANS)=U
 . I $L($P(X,"."))>24 S DIEVANS=U Q
 I %B["S" S X=$$UP^DILIBF(X)
 S %A=%B1_","_%B2_",V",%E=0,DIR("V")="",%T=$E(%B1)
 S DIEVECNT=$G(DIERR)
 D 1^DIR1
 I DIEVECNT'=$G(DIERR) S DIEVANS=U D HKERR^DILIBF(%B1,$G(DIEVIEN),%B2,"screen on a pointer or set of codes or in an input transform") Q
 I %E S DIEVANS=U Q
 S DIEVANS=$S(%B'["P":Y,1:$P(Y,U))
 I DIEVFLG["E" D
 . I %B["S"!(%B["D") S DIEVANS(0)=$P(Y(0),U)
 . E  I %B["P" S DIEVANS(0)=Y(0,0)
 . E  I %B["O" D
 . . S Y=X
 . . S DIEVECNT=$G(DIERR)
 . . X $G(^DD(%B1,%B2,2))
 . . I DIEVECNT'=$G(DIERR) D HKERR^DILIBF(%B1,$G(DIEVIEN),%B2,"output transform") Q
 . . S DIEVANS(0)=Y
 . . Q
 . E  S DIEVANS(0)=X
 . Q
 Q
 ;
FDA ;
 I $G(DIEVFAR)="" D BLD^DIALOG(202,"FDA") Q
 D LOAD^DIEF1(DIEVF,DIEVIEN,DIEVFLD,"",DIEVANS,DIEVFAR)
 Q
 ;
ERR ;
 N INT,EXT
 S INT(1)=$$FLDNM^DIEFU(DIEVF,DIEVFLD),INT(2)=$$FILENM^DIEFU(DIEVF),(INT(3),EXT(3))=DIEVAL
 S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD,EXT("IENS")=$G(DIEVIEN)
 D BLD^DIALOG(701,.INT,.EXT)
 I DIEVFLG["H" D GET^DIEH(DIEVF,"",DIEVFLD,"?b") ;DA() and D0,D1,etc. passed thru symbol table
 Q
 ;
CHKX ;
 N DIEV0,DIEVP2 K DIEVANS
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 S DIEVFLG=$G(DIEVFLG) I '$$VERFLG^DIEFU(DIEVFLG,"HE") G OUT
 D FLDVAL I $G(DIEVAL)=U D OUT Q
 D MINVAL
 Q

DIEV1
DIEV1 ;SFISC/DPC -- VARIABLE POINTER VALIDATION ;5/9/94  09:15
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
VP(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEV0,DIVPOUT) ;
 N DIVPY,DIVPHITF,DIVPZ,DIVPVP,DIVPRNUM,DIVPFILE,DIVPSAVV,DIVPAMB,DIVPFLK
 K DIVPOUT
 S DIVPAMB=0
 I DIEVAL'["."!($P(DIEVAL,".")="") D ALL,DONE Q
 S DIVPSAVV=DIEVAL,DIVPFLK=$P(DIVPSAVV,"."),DIEVAL=$P(DIVPSAVV,".",2,99)
 N DIVPVPS D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
 I $D(DIVPVPS) D
 . S DIVPVP=""
 . F  S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP=""  D FINDVP Q:DIVPAMB
 I DIVPAMB S DIVPOUT=U Q
 I $D(DIVPY) D DONE Q
 S DIEVAL=DIVPSAVV
 D ALL,DONE
 Q
 ;
ALL ;
 N DIVPORD S DIVPORD=0
 F  S DIVPORD=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD)) Q:'DIVPORD  D  Q:DIVPAMB
 . S DIVPVP=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD,""))
 . D FINDVP
 Q
 ;
VPNUMS(DIEVF,DIEVFLD,DIVPFLK,DIVPVPS) ;
 I $D(^DD(DIEVF,DIEVFLD,"V","P",DIVPFLK)) S DIVPVPS($O(^(DIVPFLK,"")))="" Q
 N DIVPMES S DIVPMES=""
 F  S DIVPMES=$O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES)) Q:DIVPMES=""  D
 . I $P(DIVPMES,DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES,"")))=""
 S DIVPFILE=0
 F  S DIVPFILE=$O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE)) Q:DIVPFILE=""  D
 . I $P($$GET1^DID(DIVPFILE,"","","NAME"),DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE,"")))=""
 Q
 ;
FINDVP ;
 S DIVPZ=^DD(DIEVF,DIEVFLD,"V",DIVPVP,0)
 S DIVPFILE=+DIVPZ Q:'DIVPFILE
 N DIVPECNT S DIVPECNT=$G(DIERR)
 I $P(DIVPZ,U,5)="y" N DIC X ^DD(DIEVF,DIEVFLD,"V",DIVPVP,1)
 I DIVPECNT'=$G(DIERR) D HKERR^DILIBF(DIEVF,"",DIEVFLD,"variable pointer screen") Q
 S DIVPRNUM=$$FIND1^DIC(DIVPFILE,"","",DIEVAL,"",$G(DIC("S")))
 I $D(^TMP("DIERR",$J,"E",299)) K DIVPY S DIVPAMB=1
 I 'DIVPRNUM Q
 I DIVPRNUM,'$D(DIVPY) S DIVPY=DIVPRNUM,DIVPHITF=DIVPFILE Q
 I DIVPRNUM,$D(DIVPY) D
 . K DIVPY
 . S DIVPAMB=1
 . N DIVPP S DIVPP(1)=DIEVAL D BLD^DIALOG(299,.DIVPP,.DIVPP)
 Q
 ;
DONE ;
 I '$G(DIVPY) S DIVPOUT=U Q
 S DIVPOUT=DIVPY_";"_$E($$GET1^DID(DIVPHITF,"","","GLOBAL NAME"),2,99)
 D IT
 I DIVPOUT=U Q 
 I DIEVFLG["E" S DIVPOUT(0)=$$EXTERNAL^DILFD(DIEVF,DIEVFLD,"",DIVPOUT)
 Q
 ;
IT ;
 N X S X=DIVPOUT
 N DIVPECNT S DIVPECNT=$G(DIERR)
 I $G(DIEV0) X $P(DIEV0,U,5,99)
 I '$G(DIEV0) X $P(^DD(DIEVF,DIEVFLD,0),U,5,99)
 I DIVPECNT'=$G(DIERR) S DIVPOUT=U D HKERR^DILIBF(DIEVF,"",DIEVFLD,"input transform") Q
 S DIVPOUT=$G(X,U)
 Q
 ;
VPFILES(DIEVF,DIEVFLD,DIVPFLK,DIVPANS) ;
 N DIVPVPS,DIEVFILE
 D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
 I '$D(DIVPVPS) Q
 N DIVPVP S DIVPVP=""
 F  S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP=""  D
 . S DIVPANS(+^DD(DIEVF,DIEVFLD,"V",DIVPVP,0))=""
 Q

DIEZ
DIEZ ;SFISC/GFT-COMPILE INPUT TEMPLATE ;10/4/94  11:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) G K
EN1 D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $$EZBLD^DIALOG(820),$C(7) G K
 S U="^" S:'$G(DTIME) DTIME=300 N L,DNM
 D SIZ^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!('X) K S DMAX=X Q:$D(DIX)
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
 D RNM^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC
 W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) K
 S X=DNM,Y=DIPZ K DIPZ
EN ;
 W:'$G(DIEZS) ! K ^UTILITY($J),DRN N L,DIEZQ,DIR S DMAX=DMAX-2150,DNM=X,DIEZ=+Y,DRN="",DRD=0,DIEZQ=0
 S DP=$P(^DIE(DIEZ,0),U,4),DIE=^DIC(DP,0,"GL")
 I '$D(^DIE(DIEZ,"DR",1,DP)) S ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR")
 D DT^DICRW S X=-1
 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
 F T=0:0 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)
 K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),DL=1,DIEZL=0,DIEZAB=U
 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
 S X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ="_DIEZ_",U=""^""" G ^DIEZ0
 ;
NEWROU ;
 K ^UTILITY($J,0) S DQ=0,T=99,L=3
 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),^(2)=" D DE G BEGIN",^(3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1"
 Q
 ;
EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing
 ;and optionally return list of routines built and if successful
 ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY
 ;Y=TEMPLATE IEN (required)
 ;FLAGS="T"alk  (optional)
 ;X=ROUTINE NAME (required)
 ;DMAX=ROUTINE SIZE (optional)
 ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional)
 ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
 ;*
 ;DIEZS will be used to indicate "silent" if set to 1
 ;Write statements are made conditional, if not "silent"
 ;*
 N DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF
 N DIK,DIC,%I,DICS
 S DIEZS=$G(DIEZFLGS)'["T"
 S:DIEZS DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D
 .N Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS
 .D INIZE^DIEFU
 I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E
 I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E
 I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E
 I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E
 I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E
 S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y
 S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU")
 S DIEZRLAF=""
 K @DIEZRLA
 D EN
 G:'DIEZS!(DIEZRLAF) EN2E
 D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:""))
EN2E I 'DIEZS D MSG^DIALOG() Q
 I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG)
 Q
 ;
RECOMP S DIX=1 D DIEZ Q:'$D(DIX)  N DIMAX S DIMAX=DMAX
 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
 ;
K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q
 ;DIALOG #101  'only those with programmer's access'
 ;       #820  'no way to save routines on the system'
 ;       #8020 'Should the compilation run now?'
 ;       #8024 'Compiling template name Input template of file n'
 ;       #8033 'Input template'

DIEZ0
DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;08:54 AM  22 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D L
DL S DQ=0,DK=0,DQFF=0
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=""
 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"
 .I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q
 .I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1)
 .Q
 S (DI,DM)=+DI G S
K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S
NX ;
 S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
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)
 S X=DIEZP,DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S
 W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S "
 K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2
 I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0
 I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2
 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
 I $D(DIEZOT) S X=DIEZOT D L K DIEZOT
 I $O(^DD(DP,DI,1,0))>0!(DV["a") S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_"""" D L
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)
 I DPR?1"//".E S %=""
 D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX
 S X=X_% D L I DV["F" S X=" I $D(X),X'?.ANP K X" D L
 S X=" Q" D L S X=" ;" D L G NX
 ;
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
 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
 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
 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
 S X=X_"D X"_DQ_" 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"
M D L G MR
 ;
UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0
LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2
 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
 ;
PR ;
 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"
 D PR^DIEZ2:DPR]""
L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q
 ;
SV D DRN
 S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ
N G NEWROU^DIEZ
 ;
DRN F %=DRN+1:1 Q:'$D(DRN(%))

DIEZ1
DIEZ1 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;3/15/96  09:35
 ;;21.0;VA FileMan;**1,13,19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D QF^DIEZ2 S L=2,X="DE S DIE="_Q_",DIC=DIE,DP="_DP_",DL="_DL_",DIEL="_DIEZL_",DU="""" K DG,DE,DB Q:$O("_DIE_"DA,""""))=""""",DS=-1 D L S X=""
DL S DS=$O(^UTILITY($J,U,DS)) S:DS="" DS=-1 I DS<0 K ^UTILITY($J,U) G CN
 S DSN=DS S:+DS'=DS DSN=""""_DSN_"""" S DPP=0,X=X_" I $D(^("_DSN_")) S %Z=^("_DSN_")"
DP S DPP=$O(^UTILITY($J,U,DS,DPP)) I DPP="" D L S X="" G DL
 S %=$O(^(DPP,0)) I +DPP=DPP S Y="P(%Z,U,"_DPP_") S:%]"""" DE("_%_")=%"
 E  S Y="E(%Z,"_+$E(DPP,2,9)_","_+$P(DPP,",",2)_") S:%'?."" "" DE("_%_")=%"
 F %=%:0 S %=$O(^(%)) Q:'%  S Y=Y_",DE("_%_")=%"
 I $L(X)+$L(Y)>240 D L S X=" I "
 S X=X_" S %=$"_Y G DP
 ;
CN F X=" K %Z Q"," ;","W "_$S($D(^DIE(DIEZ,"W")):"S DQ(DQ)=DLB_U_DV_U_U_DW "_^("W"),1:"W !?DL+DL-2,DLB_"": """) D L
 F %=1:1 S X=$E($T(TEXT+%),4,999) Q:X=""  D L
SAVE I $L(DNM_DRN)>8 S DIEZQ=1 W:'$G(DIEZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIEZRLA)]"" DIEZRLAF=0 Q
 S X=DNM_DRN D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"ZS") N DIR D BLD^DIALOG(8025,DNM_DRN,"","DIR") W:'$G(DIEZS) !,DIR S:$G(DIEZRLA)]"" @DIEZRLA@(DNM_DRN)="",DIEZRLAF=1
 S DRN(+DRN)=U,T=0,DRN=DQ Q
 ;
L S L=L+.001,^UTILITY($J,0,L)=X Q
 ;
 ;DIALOG #1503  'routine name is too long...'
 ;       #8025  'routine filed'
 ;
TEXT ;;
 ;; Q
 ;;O D W W Y W:$X>45 !?9
 ;; I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
 ;; W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
 ;;TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
 ;; Q
 ;;A K DQ(DQ) S DQ=DQ+1
 ;;B G @DQ
 ;;RE G PR:$D(DE(DQ)) D W,TR
 ;;N I X="" G A:DV'["R",X:'DV,X:D'>0,A
 ;;RD G QS:X?."?" I X["^" D D G ^DIE17
 ;; I X="@" D D G Z^DIE2
 ;; I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
 ;;T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
 ;; K DDER G X
 ;;P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
 ;; G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
 ;; I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 ;;V D @("X"_DQ) K YS
 ;;Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 ;;X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
 ;; S X="?BAD"
 ;;QS S DZ=X D D,QQ^DIEQ G B
 ;;D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
 ;;Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
 ;;PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
 ;;R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
 ;; I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
 ;; X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
 ;;RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
 ;;I I DV'["I",DV'["#" G RD
 ;; D E^DIE0 G RD:$D(X),PR
 ;; Q
 ;;SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
 ;; I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
 ;; D ^DIR I 'DDER S %=Y(0),X=Y
 ;; Q

DIEZ2
DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;3/15/96  09:15
 ;;21.0;VA FileMan;**19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR
 K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR
 S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM
K K ^DIBT(.402,1,DIEZ),^UTILITY($J)
 K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y
 K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB
 Q
 ;
XREF ;
 S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB"
 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0  S DW=^(%,2),X=X_" S X=DE("_DQ_"),DIC=DIE" D SK
 I DV["a" S X=X_" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D L
 S X="C"_DQ_"S S X="""" Q:DG(DQ)=X  K DB"
 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0  S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK
 I DV["a" S X=X_" Q:$D(DE("_DQ_"))[0&(^DD(DP,DIFLD,""AUDIT"")=""e"")  S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D L
 S X=" Q" G L
 ;
SK D L I "Q"[DW S X=" ;" G X
 I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X
 S X=" "_DW
X D L S X="" Q
 ;
MUL ;
 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)
 G 1:DV'["W" I DPR]"" S F=0,Q=DPR D QFF S X=" S DE(1,0)="_Q D L
 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
 S ^UTILITY($J,"AF",+DV,.01,DIEZ)="" D AB G NX^DIEZ0
 ;
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]""
 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
 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
 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
 D PR^DIEZ0 S X="R"_DQ_" D DE" D L
 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
 S DRN(DNR)=+DV_U_(DL+1)_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0
 ;
AF ;
 S ^UTILITY($J,"AF",DP,DI,DIEZ)=""
AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")=""
 Q
 ;
DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU=""
L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q
 ;
O ;
 S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q
 ;
PR ;
 F %=1,2,3 Q:$E(DPR,%)'="/"
 S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q
 E  S X=" "_$E(X,2,999) D L S X=" S Y=X"
 D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=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")
 Q
QF ;
 S F=0,Q=DIE
QFF ;
 S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF
 S Q=""""_Q_""""

DIFG
DIFG ;SFISC/DG(OHPRD)-FILEGRAM INSTALLER ;2/3/93  1:52 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $D(DIFGREI) S DIFGLO="^DIAR(1.13,"_DIFGREI_",21," K DIFGLC
 I '$D(DIFGLO) S DIFGER="1^0" Q
 I $E(DIFGLO,$L(DIFGLO))=","!($E(DIFGLO,$L(DIFGLO))="(")
 E  S DIFGER="1.25^0" K DIFGLO,DIFGREI Q
 S DIFGCHKG=$S($E(DIFGLO,$L(DIFGLO))=",":$E(DIFGLO,1,$L(DIFGLO)-1)_")",1:$P(DIFGLO,"("))
 I '$D(@(DIFGCHKG)) S DIFGER="1.5^0" K DIFGCHKG,DIFGLO,DIFGREI Q
 D INIT,START,KILLVAR,EOJ^DIFG5
 Q
 ;
INIT S U="^"
 K ^UTILITY("DIFG",$J),^UTILITY("DIFGFG",$J),^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J)
 D DT^DICRW
 S DIFGEXC="F DIFGL=1:1 Q:$E(DIFGDIX,DIFGL)'="" """
 S DIFGLINE="S DIFGY=$O("_DIFGLO_"DIFGY)) Q:DIFGY'>0  S DIFGDIX=^(DIFGY,0) X DIFGEXC S DIFGDIX=$E(DIFGDIX,DIFGL,255)"
 Q
 ;
START S (DIFG,DIFGER,DIFGMULT,DIFGEND,DIFGO,DIFGCT,DIFGADD,DIFGTYPE,DIFGINCR,DIFGNDC)=0,DIFGY=$S('$D(DIFGLC):.9999,1:DIFGLC-.0001),DIFGNODL=1 D FILEGRAM,KILLVAR
 D:'DIFGER ^DIFG6
 Q
 ;
FILEGRAM X DIFGLINE
 I $P(DIFGDIX,"^")'="$DAT" S DIFGER=2_U_DIFGY D ERROR G X1
 S DIFG("PARAM")=$P(DIFGDIX,U,4)
 X DIFGLINE
A I $P(DIFGDIX,":")="ENVIRONMENT" S @($P($P(DIFGDIX,":",2),"=")_"="_$P(DIFGDIX,"=",2)) X DIFGLINE G A
 D BASEFILE^DIFG0B G:DIFGER X1
 D FILE
X1 Q
 ;
FILE F DIFGL=0:0 X DIFGLINE D EVAL I DIFGTYPE="TERM"!DIFGER S DIFGTYPE="" Q
 Q
 ;
EVAL D GETTYPE
 I DIFGER G X3
 I DIFGTYPE="TERM" G X3
 I DIFGTYPE="MV FIELD" D ^DIFG2 G X3
 I DIFGTYPE="SV FIELD" D ^DIFG1 G X3
 I DIFGTYPE="WP FIELD" D ^DIFG1 G X3
 I DIFGTYPE="SWITCH" D SWITCH^DIFG0A G X3
 I DIFGTYPE="SKIP" ;computed field, do not process
X3 Q
 ;
GETTYPE I DIFGDIX="^"!(DIFGDIX=":")!(DIFGDIX="$END DAT") S DIFGTYPE="TERM" G X4
 I $P(DIFGDIX,U)="$DAT"!($P(DIFGDIX,":")="$DAT") S DIFGER=3_U_DIFGY,DIFGEND=1,DIFGTYPE="TERM" D ERROR G X4
 I $P(DIFGDIX,U,2)[":" S DIFGSTRT=$F(DIFGDIX,"^"),DIFGFIND=$E(DIFGDIX,DIFGSTRT,245) I $E(DIFGFIND,$F(DIFGFIND,":"))="^" S DIFGTYPE="SWITCH" G X4
 D EVALFLD
X4 Q
 ;
EVALFLD I DIFG("PARAM")["N" S DIFGNUM=+$P(DIFGDIX,U,2)
 E  S DIFGNUM=$O(^DD(DIC,"B",$P(DIFGDIX,U),""))
 I '$D(^DD(DIC,DIFGNUM)) S DIFGER=4_U_DIFGY D ERROR G X5
 I $P(^DD(DIC,DIFGNUM,0),U,2)["C" S DIFGTYPE="SKIP" G X5
 I +$P(^DD(DIC,DIFGNUM,0),U,2) S DIFGMLND=^DD(DIC,DIFGNUM,0),DIFGFLDN=DIFGNUM,DIFGNUM=+$P(DIFGMLND,U,2) S DIFGTYPE=$S($P(^DD(DIFGNUM,.01,0),U,2)'["W":"MV FIELD",1:"WP FIELD")
 E  S DIFGTYPE="SV FIELD"
X5 Q
 ;
ERROR NEW DA,DIC,DIE,X,Y
 S X=$P(DIFGER,U,2),DIC("DR")=".02////"_$P(DIFGER,U),DIC="^DIAR(1.13,",DIC(0)="FL" D FILE^DICN S DIFGLOG=$S(Y>0:+Y,1:-1) G:DIFGLOG=-1 X6
 S B=0 F A=$S($D(DIFGLC):DIFGLC-.0001,1:0):0 S A=$O(@(DIFGLO_"A)")) Q:'A  S B=B+1,^DIAR(1.13,+Y,21,B,0)=$S('$D(^UTILITY("DIFGFG",$J,A)):@(DIFGLO_"A,0)"),1:^UTILITY("DIFGFG",$J,A)) S:A=$P(DIFGER,U,2) $P(DIFGER,U,2)=B Q:^(0)["$END DAT"
 S ^DIAR(1.13,+Y,21,0)="^^"_B_"^"_B_"^"_DT
 S DIE="^DIAR(1.13,",DA=DIFGLOG,DR=".01///"_$P(DIFGER,U,2) D ^DIE K DIE,DA,DR
 S DIFGEROR=""
X6 K A,B Q
 ;
KILLVAR K DIFGFILE,DIFGSAVE,DA,DIC,DIFGTYPE,DIFGM,DIFGNDC,DIFGNODL,DIFGADD,DIFGMO,DIFGLAGO,DIFGSKIP,DIFGDI,DIFGDICS,DIFGADD,DIFGINCR,DIFGNODL,DIFGTYPE,DIFG("SAVE")
 K DIFGDA,DIFGDIC,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGNODE,DIFGNUM,DIFGSECP,DIFGSTRT,DIFGSVN,DIFGSVVL,DIFGMGBL
 Q

DIFG0
DIFG0 ;SFISC/DG(OHPRD)-SETS UP DIC("S"), EVALS 1ST LINE OF A (SUB)FILE ; [ 05/25/93  10:17 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NDPC ;DETERMINE NODE,PIECE FOR DATA FOR THIS FIELD
 S DIFGCT=DIFGCT+1
 S:DIFG("PARAM")["N" DIFGNUMF(DIFGCT)=+$P(DIFGDIX,"^",2),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
 I '$D(DIFGPC(DIFGCT)) S DIFGNUMF(DIFGCT)=$O(^DD(DIC,"B",$P($P(DIFGDIX,"^"),":",2),"")),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
 S DIFGHAT=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,2) I DIFGHAT["P",$P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S DIFGPTER(DIFGCT)=""
 D DICS
 D GETVAL
 Q
 ;
DICS ;SET DIC("S")
 I $P(DIFGPC(DIFGCT),";",2)'["," S DIFGDOL="$P(^($P(DIFGPC("_DIFGCT_"),"";"")),U,$P(DIFGPC("_DIFGCT_"),"";"",2))="
 E  S DIFGDOL="$E(^($P(DIFGPC("_DIFGCT_"),"";"")),$P(DIFGPC("_DIFGCT_"),"";"",2))="
 I '$D(DIFGDIC(DIC)) S DIFGDICS(DIC)=1
 E  S DIFGDICS(DIC)=DIFGDICS(DIC)+1
 S DIFGDIC(DIC,DIFGDICS(DIC))="I "_DIFGDOL_$S($D(DIFGPTER(DIFGCT)):"",1:"DIFGVAL("_DIFGCT_")")
 Q
 ;
GETVAL ;GETS VALUE TO RIGHT OF EQUAL SIGN
 I $P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S (DIFGVAL(DIFGCT),^UTILITY("DIFGX",$J,DIFGCT))=$P(DIFGDIX,"=",2) D:DIFGHAT["S" SETCODES D:DIFGHAT["D" DATE I 1
 E  S DIFGVAL(DIFGCT)=^UTILITY("DIFG@",$J,$P(DIFGDIX,"=",2)) S:$D(^UTILITY("DIFGX",$J,$P(DIFGDIX,"=",2))) ^UTILITY("DIFGX",$J,DIFGCT)=^($P(DIFGDIX,"=",2))
X1 Q
 ;
SETCODES ;DETERMINE INTERNAL VALUE IF FIELD ATTRIBUTE IS SET OF CODES
 I $P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3)[":"_DIFGVAL(DIFGCT)_";" S DIFGSET=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3),%=$P(DIFGSET,":"_DIFGVAL(DIFGCT)_";"),%A=$L(%,";"),DIFGVAL(DIFGCT)=$P(%,";",%A)
 K DIFGSET,%,%A
 Q
 ;
DATE ;GET INTERNAL FORM OF DATE
 S DIFGSAVX=X,%DT="T",X=$P(DIFGDIX,"=",2) D ^%DT S DIFGVAL(DIFGCT)=Y,X=DIFGSAVX
 I Y=-1 S DIFGER=5_U_DIFGY D ERROR^DIFG
 Q
 ;
BASE ;BASE FILE ENTRY LINE
 K DIFGXRF(DIFGMULT)
 I $P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N1"E" S (DIFGALNK,Y)=^UTILITY("DIFG@",$J,$E($P($P(DIFGDIX,U,3),"=",2),1,$L($P($P(DIFGDIX,U,3),"=",2))-1)),DIFGFLUS="" S:'Y DIFGSKIP(DIFGMULT)="" S DIFG("NOLKUP")=""
 I '$D(DIFG("NOLKUP")) S X=$S($P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N:"`"_$S(^UTILITY("DIFG@",$J,$P($P(DIFGDIX,U,3),"=",2))["^UTILITY":"^"_$P(^($P($P(DIFGDIX,U,3),"=",2)),U,2),1:$P(^($P($P(DIFGDIX,U,3),"=",2)),U)),1:$P($P(DIFGDIX,U,3),"=",2))
 I '$D(DIC) S DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),$D(^DIC("B",$P(DIFGDIX,U))):$O(^DIC("B",$P(DIFGDIX,U),"")),1:"") I DIC S:'$D(^DIC(DIC)) DIC=""
 I 'DIC S DIFGER=20_U_DIFGY D ERROR^DIFG
 I $P(DIFGDIX,U,4)]"" S DIFGXRF(DIFGMULT)=$P(DIFGDIX,U,4)
 Q
 ;
FUNC ;CHECKS FUNCTION ON BASE ENTRY LINE
 S DIFGO=DIFGO+1
 S DIFGINCR=DIFGO
 S %=$P(DIFGDIX,U,3),%=$P(%,"="),^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE")=$S(%?1A:%,1:"L")_"^"_DIFGY S DIFGMO(DIFGMULT)=$P(^("MODE"),U)_"^"_DIC
 K %
 Q
 ;

DIFG0A
DIFG0A ;SFISC/DG(OHPRD)-CALLED FOR CONTEXT SWITCH ;6/5/92  12:32 PM [ 03/13/96  7:42 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;IHS/TUCSON/LAB - 3/13/96 - modified KILLVAR subroutine to
 ;prevent subscript errors in filegram installs
SWITCH ;CONTEXT SWITCH
 N DIC,DIFGM,DIFGNDC,DA,DIFGINCR,DIFGSKIP,DIFGDI,DIFGMO,DIFGPOIN
 S DIFG=DIFG+1,(DIFGNDC,DIFGLAGO)=0
 S DIFGTYPE="FILE"
 D BASE^DIFG0
 I DIFGER G X1
 D FUNC^DIFG0
 I '$D(DIFG("NOLKUP")) D BEGEND
 I DIFGER G X1
 D SET
 D KILLVAR0
 D FILE^DIFG
 S DIFG=DIFG-1
 D KILLVAR
X1 Q
 ;
BEGEND ;CALL DIFG3 TO PROCESS BEGIN-END BLOCK
 I "AL"[$P(DIFGMO(DIFGMULT),U) S DIFGSECP=$P(^DD(DIC,.01,0),U,2) S:DIFGSECP["P" DIFGPOIN="" I DIFGSECP'["'"!($D(DIFGENV("LAYGO",DIC,.01))) S DIFGLAGO=1
 D ^DIFG3
 Q
 ;
SET ;
 I '$D(DIFGSKIP(DIFGMULT)),$D(^UTILITY("DIFG",$J,DIFGINCR,DIC)),'$D(^(DIC,"DA")) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=+Y,^("DR")=""
 I $D(DIFGSKIP(DIFGMULT)) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=DIFGALNK S:'$D(DIFGFLUS) ^("X")=$S($E(X)="`":$E(X,2,245)_"^N",X[("^UTILITY(""DIFG@"","_$J):X_"^N",1:X)
 I $D(DIFGFLUS),$P(DIFGMO(DIFGMULT),U)="L" S $P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="M"
 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"GL")=^DIC(DIC,0,"GL"),(DA,DIFGDA(0))=DIFGALNK I $D(^("DIC(""DR"")")) S ^("MODE")="A"_"^"_$P(^("MODE"),U,2)
X2 K DIFGFLUS Q
 ;
KILLVAR0 ;KILL VARIABLES AFTER LOOKUP FOR FILE ON THE WAY TO FIELDS
 K DIFGALNK,DIFGO(DIFGMULT),DIFGFLD,DIFGPC,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP")
 Q
 ;
KILLVAR ;KILL VARIABLES AFTER EACH CONTEXT SWITCH
 ;K DIFGDA,DIFGDIC,DIFGDOL,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGMLND,DIFGNODE,DIFGNUM,DIFGNUMF,DIFGPC,DIFGPTER,DIFGSECP,DIFGSTRT,DIFGVAL,DIFGNDC,DIFGM,DIFGFLD,DIFGNOLK($P(DIFGMO(DIFGMULT),U,2)),DIFGDIC,DIFGSAVE,DIFGSVVL
 ;IHS/TUCSON/LAB - commented out line above and replaced it with
 ;the 2 lines below - 03/13/96 - the 2nd piece of DIFGMO(DIFGMULT) is 
 ;sometimes null, causing a subscript error
 K DIFGDA,DIFGDIC,DIFGDOL,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGMLND,DIFGNODE,DIFGNUM,DIFGNUMF,DIFGPC,DIFGPTER,DIFGSECP,DIFGSTRT,DIFGVAL,DIFGNDC,DIFGM,DIFGFLD,DIFGDIC,DIFGSAVE,DIFGSVVL
 K:$P($G(DIFGMO(DIFGMULT)),U,2)]"" DIFGMOLK($P(DIFGMO(DIFGMULT),U,2))
 K DIFGSKIP
 Q
 ;

DIFG0B
DIFG0B ;SFISC/DG(OHPRD)-PROCESS BASEFILE ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
BASEFILE ;
 S DIFGTYPE="FILE"
 D BASE^DIFG0 G:DIFGER X2 D FUNC^DIFG0
 S DIFGLAGO=0
 I $P(DIFGMO(DIFGMULT),U)="L",$D(DINUM),$D(@(^DIC(DIC,0,"GL")_"DINUM)")) S $P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="M",$P(DIFGMO(DIFGMULT),U)="M"
 E  I "AL"[$P(DIFGMO(DIFGMULT),U) S DIFGSECP=$P(^DD(DIC,.01,0),U,2) I DIFGSECP'["'"!($D(DIFGENV("LAYGO",DIC,.01))) S DIFGLAGO=1
 I $D(DINUM),$P(^DD(DIC,.01,0),U,5,99)["DINUM","MD"'[$P(DIFGMO(DIFGMULT),U) S DIFGER=7_U_DIFGY D ERROR^DIFG G X2
 I $D(DINUM) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,$S("MD"[$P(DIFGMO(DIFGMULT),U):"DA",1:"DINUM"))=DINUM
 I $D(DIADD) S:"AL"'[$P(DIFGMO(DIFGMULT),U) DIFGER=8_U_DIFGY D:DIFGER ERROR^DIFG I 'DIFGER S $P(DIFGMO(DIFGMULT),U)="A",$P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="A"
 K DIADD,DINUM
 I DIFGER G X2
 S:$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")) DIFGDINM="" D ^DIFG3
 I DIFGER G X2
 K DIFGLAGO
 D SET^DIFG0A
 D KILLVAR0^DIFG0A
 S DIFGBSE=^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")_"^"_DIC_$S(^("MODE")["A":"^1",1:"")
X2 Q
 ;

DIFG1
DIFG1 ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ; [ 02/03/93  3:17 PM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;ASSIGNMENT STATEMENT FOR SINGLE VALUED FIELD
 I DIFGTYPE="WP FIELD" D WPFIELD G X1
 S DIFGSECP=$P(DIFGDIX,"=",2)
 I DIFGSECP="^" S DIFGVAL="@" D SETDR G X1
 I DIFGSECP?1"@"1N.N,'^UTILITY("DIFG@",$J,DIFGSECP),$D(DIFG("UNRESOLVED",DIFGSECP)) S DIFGER=21_U_DIFGY D ERROR^DIFG G X2
 I $P(^DD(DIC,DIFGNUM,0),U,2)["P",DIFGSECP'?1"@"1N.N D LOOKUP I 1
 E  I DIFGSECP'?1"@"1N.N,DIFGSECP[";" D PARSE S DIFGVAL="^S X="_DIFGSECP I 1
 E  S DIFGVAL=$S(DIFGSECP'?1"@"1N.N:DIFGSECP,^UTILITY("DIFG@",$J,DIFGSECP)[DIFGSECP:"^S X="_"""`""_^UTILITY(""DIFG@"","_$J_","""_DIFGSECP_""")",DIFGNUM'=.01:"/"_^UTILITY("DIFG@",$J,DIFGSECP),1:"`"_^UTILITY("DIFG@",$J,DIFGSECP))
 I DIFGER G X1
 D SETDR
 K DIFGSECP,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNOLK,DIFGPARS,DIFGDOLF
X1 Q
 ;
PARSE ; PARSE AND CHANGE DIFGSECP IF CONTAINS ";"
 NEW I S DIFGPARS="" F I=0:0 S DIFGDOLF=$F(DIFGSECP,";") Q:'DIFGDOLF  S DIFGPARS=DIFGPARS_$S(DIFGDOLF>2:""""_$E(DIFGSECP,1,DIFGDOLF-2)_"""_",1:"")_"$C(59)_" S DIFGSECP=$E(DIFGSECP,DIFGDOLF,245)
 S DIFGSECP=$S(DIFGSECP="":$E(DIFGPARS,1,$L(DIFGPARS)-1),1:DIFGPARS_""""_DIFGSECP_"""")
 Q
 ;
SETDR ;
 S:'$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR")) ^("DR")=""
 I $L(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR"))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^("DR")=^("DR")_DIFGNUM_"///"_DIFGVAL_";" G X2
 I $D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR",DIFGNDC)),$L(^(DIFGNDC))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^(DIFGNDC)=^(DIFGNDC)_DIFGNUM_"///"_DIFGVAL_";"
 E  S DIFGNDC=DIFGNDC+1,^(DIFGNDC)=DIFGNUM_"///"_DIFGVAL_";"
X2 Q
 ;
LOOKUP ;FIELD LOOKUP
 S DIFG=DIFG+1
 S X=$P(DIFGDIX,"=",2)
 S DIFGLAGO=0
 I $P(^DD(DIC,DIFGNUM,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIC,DIFGNUM))) S DIFGLAGO=1
 D ^DIFG3
 I DIFGER G X3
 I Y>0 S DIFGVAL="/"_+Y G X3
 S DIFGVAL="^S X="_"""`""_"_DIFGALNK
X3 S DIFG=DIFG-1
 K Y,DIFGLAGO
 Q
 ;
WPFIELD ;PROCESS WP FIELD
 S DIFG("COUNT")=0
 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=DIFGFLDN
 F DIFGL=0:0 X DIFGLINE Q:DIFGDIX="."  S DIFG("COUNT")=DIFG("COUNT")+1 D BUILD
 K DIFG("COUNT")
 Q
 ;
BUILD ;
 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$E(DIFGDIX,2,$L(DIFGDIX)-1)
 Q
 ;

DIFG2
DIFG2 ;SFISC/DG(OHPRD)-PROCESSING OF MULTIPLES FROM FILEGRAM ; [ 02/02/93  4:21 PM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;CALLED BY DIFG
 S DIFG=DIFG+1
 I DIFGMULT=0 S DIFGNDC=0,DIFGM(0)=DIC ;ENTERING HIGHEST LEVEL MULTIPLE
 N DIC
 D MULT
 I DIFGER G X1
 I '$D(DIFG("NOLKUP")) D ^DIFG3 I 1
 E  D NOLOOK
 I DIFGER G X1
 D SET
 K DIFGALNK,DIFGMLND,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP"),DIFG("ACGRV"),DIFGDIC(DIFGDIC)
 D FILE^DIFG
 K DIFGSKIP(DIFGMULT) ;Going up one level so kill this variable which tells lower level multiples not to do lookup
 D CHANGEDA
 S DIFG=DIFG-1
X1 Q
 ;
MULT ;MULTIPLE FIELD LOOKUP AND CALL TO SET DR STRING FOR MULTIPLE
 I DIFGMULT=0 S DIFGMGBL(DIFGMULT)=$S(DIFGM(0):^DIC(DIFGM(0),0,"GL"),1:DIC),DIFGDA(DIFGMULT)=DA
 S DIFGNODE=$P($P(DIFGMLND,"^",4),";")
 S DIFGLAGO=0
 I $P(^DD(DIFGNUM,.01,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIFGNUM,.01))) S DIFGLAGO=1 ;Not a ptr or a ptr and laygo allowed
 S DIFGMULT=DIFGMULT+1
 I $D(DIFGSKIP(DIFGMULT-1)) S DIFGSKIP(DIFGMULT)=""
 S DIFGMGBL(DIFGMULT)=DIFGMGBL(DIFGMULT-1)_DIFGDA(DIFGMULT-1)_","_""""_DIFGNODE_""""_","
 S DIFGM(DIFGMULT)=DIFGNUM
 S DIC=DIFGNUM D BASE^DIFG0 Q:DIFGER  D FUNC^DIFG0
 Q
 ;
NOLOOK ;IF NO LOOKUP REQUIRED, SET DA ARRAY
 F DIFGI=DIFGMULT:-1:1 S DA(DIFGI)=$S(DIFGI=1:DA,1:DA(DIFGI-1))
 Q
 ;
SET ;
 I '$D(DIFGSKIP(DIFGMULT)) S (DA,DIFGDA(DIFGMULT))=+Y
 E  S (DA,DIFGDA(DIFGMULT))=DIFGALNK I '$D(DIFGFLUS) D
 . S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"X")=$S($E(X)="`":$E(X,2,245)_"^N",($D(DIFG("ACGRV"))!(X[("^UTILITY(""DIFG@"","_$J))):X_"^N",1:X_"^"),^("MODE")="A"_"^"_$P(^("MODE"),U,2),^("DIC(""P"")")=$P(DIFGMLND,U,2)
 S DIC=DIFGM(DIFGMULT)
 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=DA,^("GL")=DIFGMGBL(DIFGMULT),^($S($D(DIFGSKIP(DIFGMULT))&('$D(DIFGFLUS)):"DIC(""DR"")",1:"DR"))="" F DIFGI=1:1:DIFGMULT S ^("DA("_DIFGI_")")=DA(DIFGI)
 I $D(DIFGSKIP(DIFGMULT)),'$D(DIFGFLUS) D ENADD^DIFG4
 K DIFGTYP,DIFGFLUS ;DIFGTYP exists due to DIFG3 not killing it if DIFGTYP="MV FIELD" - Needed in case one calls ENADD^DIFG4
 Q
 ;
CHANGEDA ;BACK DOWN ONE LEVEL DA'S, I.E. DA=DA(1),DA(1)=DA(2) ETC.
 S DA=DA(1)
 I DIFGMULT>1 F DIFGI=DIFGMULT:-1:2 S DA(DIFGI-1)=DA(DIFGI)
 K DA(DIFGMULT)
 S DIFGMULT=DIFGMULT-1
 Q
 ;

DIFG3
DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93  1:33 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIFGTYP="" X DIFGLINE
 N DIC,DIFGDRAD,DIFGDRCT,DIFGFLUS
 S DIFG=DIFG+1
 D BEGIN G:DIFGER X5
 S DIFGTYP=$S(DIFGTYPE="MV FIELD":"MV FIELD",DIFGTYPE="SV FIELD":"SV FIELD",1:"FILE")
 I $D(DIFGDINM) K DIFGDINM S Y=^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA") S:'$D(@(^DIC(DIC,0,"GL")_"Y)")) DIFGER=19_U_DIFGY D ERROR^DIFG:DIFGER,SET^DIFG3A:'DIFGER G X5
 I '$D(DIFGNOLK) D PREDIC I 1
 E  I DIFGTYP="MV FIELD",$D(DIFGNOLK) D MVFIELD^DIFG3A I 1
 E  S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A
X5 S DIFG=DIFG-1 K DIFGNOLK,DIFGCOND,DIFG("CONDSET") I DIFGTYP'="MV FIELD" K DIFGTYP
 Q
BEGIN I $P(DIFGDIX,":")'="BEGIN" S DIFGER=6_U_DIFGY D ERROR^DIFG G X
 S DIFGDRCT=0,DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),1:$O(^DIC("B",$P($P(DIFGDIX,U),":",2),""))),DIC("S")="F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!('$T)  X DIFGDIC(DIFGDIC,DIFGI)"
 I '$D(^DD(DIC)) S DIFGER=20_U_DIFGY D ERROR^DIFG G X
 I DIFGTYP="" S %=DIFGLAGO NEW DIFGLAGO S DIFGHAT=$P(^DD(DIC,.01,0),U,2) S DIFGLAGO=$S(%=0:0,DIFGHAT'["'":1,$D(DIFGENV("LAYGO",DIC,.01)):1,1:0) K %
 K DIFGHAT
 I DIFGTYPE="SV FIELD"!($D(DIFG("CHKCOND"))) S:$D(^DD(DIC,0,"FD")) DIFGCOND(DIFG,DIC)="" K DIFG("CHKCOND")
 D LINK^DIFG5
 F DIFGL=0:0 X DIFGLINE S DIFGFIRP=$P(DIFGDIX,":") Q:DIFGFIRP="END"!DIFGER  D LINES
 Q
LINES I DIFGFIRP="BEGIN" D RCR S:$S($D(Y):Y<0,1:1) DIFGNOLK="" G:DIFGER X S:'$D(DIFGNOLK) X="`"_+Y S:$D(DIFGNOLK)&(DIFGTYP'="MV FIELD")&(DIFGTYP'="FILE") X=DIFGALNK D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY^DIFG5 K Y G X
 I DIFGFIRP="IDENTIFIER"!(DIFGFIRP="SPECIFIER") D ^DIFG0 G:DIFGER X S:'$D(DIFGPTER(DIFGCT)) DIFGSVVL(DIFGCT)=DIFGVAL(DIFGCT) I $D(DIFGPTER(DIFGCT)) D IDENSPEC^DIFG5 G X
 I DIFGFIRP="KEY" S DIFGKEY="" D KEY^DIFG5
 I DIFGFIRP="$DAT" S DIFGER=3_U_DIFGY D ERROR^DIFG
X Q
RCR N DIC,DIFGDRAD,DIFGDRCT,DIFGNOLK,DIFGFLUS
 S DIFG=DIFG+1,DIFG("CHKCOND")=""
 D BEGIN G:DIFGER X
 I '$D(DIFGNOLK) D PREDIC I 1
 E  S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A
 I $D(DIFGDIC)#2 K DIFGCOND(DIFG,DIFGDIC)
 S DIFG=DIFG-1
 Q
PREDIC I $D(DIFGKEY) D:DIFGTYPE="MV FIELD" MVFIELD^DIFG3A G X2
 S DIFGDIC=DIC
 I DIFGTYP="MV FIELD" D MVFIELD^DIFG3A G X2
 I DIFGTYP="FILE",$P(DIFGMO(DIFGMULT),U)="A" S DIFGSKIP(DIFGMULT)="" D ^DIFG4,SET^DIFG3A G X2
 I '$D(DIFGFLUS) D CALLDIC I 1
 E  D SET^DIFG3A
X2 K DIFGKEY,DIFGSAVE(DIFG,"@NUM")
 K:DIFGTYP'="MV FIELD" DIFG("ACGRV")
 Q
CALLDIC K D
 I $D(DIFGXRF(DIFGMULT)),(DIFGTYP="MV FIELD"!(DIFGTYP="FILE")) S DIFGX=X,X=^UTILITY("DIFG@",$J,$P(DIFGXRF(DIFGMULT),"=",2)) G:X["^UTILITY(""DIFG@""" NOLK S D=$P(DIFGXRF(DIFGMULT),"="),DIC(0)="FI" D  G:$D(DIFGNK) NOLK
 . I $E(DIFGX)="`" S DIFGGRAV="",DIFGX=$E(DIFGX,2,245)
 . E  NEW X S X=DIFGX X $P(^DD(DIFGDIC,.01,0),U,5,99) S:$D(X) DIFGX=X I '$D(X) S DIFGNK="" Q
 . F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))
 . S DIFGDIC(DIFGDIC,DIFGI)="I $P(^(0),U)=DIFGX"
 E  I $E(X)'="`"!($P(^DD(DIFGDIC,.01,0),U,5,99)["DINUM") S DIC(0)="MFI"
 E  S X=$E(X,2,245),DIC(0)="FI",D="B",DIFG("ACGRV")=""
 I $D(D),'$D(^DD(DIFGDIC,0,"IX",D)) D DOLO^DIFG5 I '$D(DIFG("FOUND")) S DIFGER=18_U_DIFGY D ERROR^DIFG G X6
 K DIFGNK F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!$D(DIFGNK)  I $P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFGVAL",@$P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFG(" S DIFGNK=""
 I '$D(DIFG("FOUND")),'$D(DIFGNK) D @$S($D(D):"IX^DIC",1:"^DIC")
NOLK I X["^UTILITY(""DIFG@"""!$D(DIFGNK) S Y=-1
 I $D(DIFGX) S X=$S($D(DIFGGRAV):"`",1:"")_DIFGX K DIFGX,DIFGGRAV
 D CHECKY^DIFG5
 D:'DIFGER SET^DIFG3A
X6 K DIFG("FOUND"),D,DR,DIFGNK
 I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") K DIFGXRF(DIFGMULT)
 Q

DIFG3A
DIFG3A ;SFISC/DG(OHPRD)-SETS VARS BASED ON Y VALUE AFTER LOOKUP ;3/11/93  1:49 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SET ;SET VARIABLES BASED ON LOOKUP
 I $D(DIFGFLUS) S DIFGALNK=^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")) I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") S DIFGSKIP(DIFGMULT)=""
 E  S (DIFGALNK,^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")))=$S(($D(DIFGSKIP(DIFGMULT))&(DIFGTYP="MV FIELD"!(DIFGTYP="FILE")))!($S($D(Y):Y<0,1:1)):"^UTILITY(""DIFG@"","_$J_","""_DIFGSAVE(DIFG,"@NUM")_""")",1:+Y)
 I DIFGALNK S ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=X D EXTVAL
 I '$D(Y) S Y=-1
 I DIFGTYP="MV FIELD",$D(DIFGSKIP(DIFGMULT))
 E  K:$D(DIFGDIC) DIFGDIC(DIFGDIC),DIFGDICS(DIFGDIC)
 Q
 ;
EXTVAL ; Save external value
 K D
 I ($D(DIFG("ACGRV"))!($E(X)="`")),$D(Y),Y>0 K DIC("S") NEW Y S X=$S($E(X)="`":$E(X,2,245),1:X),DIC(0)="FIZ",D="B" D IX^DIC S:Y>0 ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=Y(0,0) I 1
 E  I ($D(DIFG("ACGRV"))!($E(X)="`")),$S('$D(Y):1,Y<0:1,1:0) NEW DIC,Y S X=$S($E(X)="`":$E(X,2,245),1:X),DIC=+$P($P(^DD(DIFGDIC,.01,0),U,2),"P",2) I DIC S DIC(0)="FIZ",D="B" D IX^DIC S:Y>0 ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=Y(0,0)
 Q
 ;
MVFIELD F DIFGI=DIFGMULT:-1:1 S DA(DIFGI)=$S(DIFGI=1:DA,1:DA(DIFGI-1))
 I $D(DIFGKEY) G X
 I $D(DIFGSKIP(DIFGMULT)) D SET G X
 I $P(DIFGMO(DIFGMULT),U)="A" S DIFGSKIP(DIFGMULT)="" D SET G X
 I '$D(DIFGFLUS) S DIC=DIFGMGBL(DIFGMULT),DIFGDIC=DIFGM(DIFGMULT) D CALLDIC^DIFG3 I 1
 E  D SET
X Q

DIFG4
DIFG4 ;SFISC/DG(OHPRD)-HANDLES FAILED IDENTIFIER, SPECIFIER, AND FIELD LOOKUPS ; [ 07/15/91  1:30 PM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
 I DIFGTYP="FILE"!(DIFGTYP="MV FIELD") S DIFGPARM=$P(DIFGMO(DIFGMULT),U) I "DM"[DIFGPARM S DIFGER=9_U_DIFGY D ERROR^DIFG G X1
 I DIFGTYP="MV FIELD" G X1 ;Call ENADD^DIFG4 from SET^DIFG2 if a MV FIELD
 I DIFGTYP="",'DIFGLAGO,'$D(DIFGCOND) S DIFGER=10_U_DIFGY D ERROR^DIFG G X1
 I DIFGTYP="",DIFGLAGO,$D(DIFG("CONDSET")),'$D(DIFGCOND) S DIFGER=24_U_DIFGY D ERROR^DIFG G X1
 I DIFGTYP="",DIFGLAGO,'$D(DIFG("CONDSET"))
 I DIFGTYP="",'DIFGLAGO,$D(DIFGCOND) D ^DIFG4A G X1
 I DIFGTYP="SV FIELD",'DIFGLAGO,'$D(DIFGCOND(DIFG,DIFGDIC)) S DIFGER=11_U_DIFGY D ERROR^DIFG G X1 ;END for the BEGIN-END block for a SV FIELD; must have laygo to the pointed to file from the field allowed OR conditional
 I DIFGTYP="SV FIELD",DIFGLAGO,$D(DIFG("CONDSET")),'$D(DIFGCOND(DIFG,DIFGDIC)) S DIFGER=24_U_DIFGY D ERROR^DIFG G X1
 I DIFGTYP="SV FIELD",DIFGLAGO,'$D(DIFG("CONDSET"))
 E  I DIFGTYP="SV FIELD",'DIFGLAGO D ^DIFG4A G X1
 D ENADD
 I $D(DIFGSVN) S DIFGADD=DIFGSVN K DIFGSVN
X1 K %,DIFGPARM,DIFGADFL Q
 ;
ENADD ;
 I DIFGTYP]"",DIFGTYP'="SV FIELD" S DIFGSVN=DIFGADD,DIFGADD=DIFGINCR,DIFGSKIP(DIFGMULT)=""
 E  S DIFGADD=DIFGADD+.0001
 I DIFGTYP'="MV FIELD",DIFGTYP'="FILE" D ENADD2
 I $D(DIFGKEY),DIFGFIRP="KEY" S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")=$S(DIFG("PARAM")["N":+$P(DIFGDIX,U,2),1:$O(^DD(DIC,"B",$P(DIFGDIX,U),"")))_"////"_$P(DIFGDIX,"=",2) G X3
 I '$D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")) S ^("DIC(""DR"")")=""
 S DIFGDRCT=0 F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))  S DIFGDIGT=+$P(DIFGDIC(DIFGDIC,DIFGI),"DIFGPC(",2) D:$D(DIFGNUMF(DIFGDIGT)) DICDR
 K DIFGDR,DIFGDRT,DIFGDRVL,DIFGDIGT,DIFGDRCT
X3 Q
 ;
ENADD2 ;SET VARS IF NOT MV FIELD OR FILE
 S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DA")="^UTILITY(""DIFG@"","_$J_","""_DIFGSAVE(DIFG,"@NUM")_""")",^("X")=$S($E(X)="`":$E(X,2,245)_"^N",(X["DIFG(""@")!($D(DIFG("ACGRV"))):X_"^N",1:X)
 S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"GL")=^DIC(DIFGDIC,0,"GL"),^("MODE")="A"_"^"_DIFGY
 Q
 ;
DICDR ;SAVE FLD NUMBERS AND VALUES IN DIC("DR")
 I DIFGSVVL(DIFGDIGT)[("^UTILITY(""DIFG@"","_$J) S DIFGDRVL=$S(+@DIFGSVVL(DIFGDIGT):"/"_@DIFGSVVL(DIFGDIGT),1:"^S X="_"""`""_"_DIFGSVVL(DIFGDIGT))
 E  S DIFGDRVL="/"_DIFGSVVL(DIFGDIGT)
 I '$D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")) S ^("DIC(""DR"")")=""
 I $L(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")"))+$L(DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";")<241 S ^("DIC(""DR"")")=^("DIC(""DR"")")_DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";" G X2
 I $D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")",DIFGDRCT)),$L(^(DIFGDRCT))+$L(DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";")<241 S ^(DIFGDRCT)=^(DIFGDRCT)_DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";"
 E  S DIFGDRCT=DIFGDRCT+1,^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")",DIFGDRCT)=DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";"
X2 K DIFGDRVL
 Q
 ;

DIFG4A
DIFG4A ;SFISC/DG(OHPRD)-CONDITIONALS ; [ 08/21/91  5:15 PM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
START ;
 D CHECK
 I $D(DIFGSTP) K DIFGSTP S DIFG("UNRESOLVED",DIFGSAVE(DIFG,"@NUM"))="" G X1
 S DIFGDRCT=0 F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))  S DIFGDIGT=+$P(DIFGDIC(DIFGDIC,DIFGI),"DIFGPC(",2) D:$D(DIFGNUMF(DIFGDIGT)) GETVAL
 I $E(X)="`",$S('$D(Y):1,Y<0:1,1:0) NEW DIC S DIC=+$P($P(^DD(DIFGDIC,.01,0),U,2),"P",2) I DIC S DIC(0)="FMZ" D ^DIC S:Y>0 X=Y(0,0)
 I X'["`" S ^UTILITY("DIFGFLD",$J,.01)=X
 K Y
 D COND ;dg/ohprd 8-21-91
 I '$D(Y) S Y=-1
 I Y>0 S DIFG("CONDSET")=""
 I Y=-1 S DIFGER=22_U_DIFGY D ERROR^DIFG
 K DIFGDRCT,DIFGDIGT,^UTILITY("DIFGFLD",$J)
X1 Q
 ;
CHECK ; Check for existence of higher level conds, if exist quit this level
 ; and continue processing
 NEW % S %=0 F  S %=$O(DIFGCOND(%)) S:%<DIFG&% DIFGSTP="" Q:%=""!(%<DIFG)
 Q
 ;
GETVAL ; Save field numbers and values
 I $D(^UTILITY("DIFGX",$J,DIFGDIGT)) S ^UTILITY("DIFGFLD",$J,DIFGNUMF(DIFGDIGT))=^(DIFGDIGT)
 Q
 ;
COND ; Execute conditions
 NEW ORDR,CNUM,NUM,STP,FLD,OP,VAL
 F ORDR=0:0 S ORDR=$O(^DD(DIFGDIC,0,"FD","B",ORDR)) Q:'ORDR!$D(Y)  S CNUM=$O(^(ORDR,"")),TYPE=$P(^DD(DIFGDIC,0,"FD",CNUM,0),U,3) K STP F NUM=0:0 S NUM=$O(^DD(DIFGDIC,0,"FD",CNUM,NUM)) D:NUM'=+NUM SETY Q:NUM'=+NUM  D  Q:$D(STP)
 . S FLD=$P(^DD(DIFGDIC,0,"FD",CNUM,NUM),U),OP=$P(^(NUM),U,2),VAL=$P(^(NUM),U,3)
 . I $S('$D(^UTILITY("DIFGFLD",$J,FLD)):1,1:0) S STP="" Q
 . I @("^UTILITY(""DIFGFLD"",$J,FLD)"_OP_"VAL")
 . E  S STP=""
 Q
 ;
SETY ; Sets Y to value of "D" node or value from execution of "C" node
 I TYPE="M",$D(^DD(DIFGDIC,0,"FD",CNUM,"C")) X ^("C")
 I TYPE="F",$D(^DD(DIFGDIC,0,"FD",CNUM,"D")) S Y=^("D")
 I $D(Y),Y'>0 K Y
 E  I $D(Y),'$D(@(^DIC(DIFGDIC,0,"GL")_"Y)")) K Y
 Q
 ;

DIFG5
DIFG5 ;SFISC/DG(OHPRD)-MISC FUNCTIONS ;3/11/93  1:25 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
CHECKY ;CHECKS Y AFTER DIC CALL
 I Y>0,DIFGTYP="FILE"!(DIFGTYP="MV FIELD"),$P(DIFGMO(DIFGMULT),U)="L" S ^("MODE")="M"_"^"_$P(^UTILITY("DIFG",$J,DIFGINCR,DIFGDIC,"MODE"),U,2)
 I Y>0 G X1
 S DIFGCHEK=0 I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") S DIFGCHEK=1
 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP'="MV FIELD" S X=$S($D(DIFG("ACGRV")):X_"^N",1:X),DIFGSKIP(DIFGMULT)="" D ^DIFG4 G X1 ;Set X to X^N if internal pointer value was used in lookup, lets ^DIFG7 know if X internal value or not
 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP="MV FIELD" S DIFGSKIP(DIFGMULT)="" G X1
 I 'DIFGCHEK D ^DIFG4 G X1
 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="D" G X1 ;If no entry found to delete, continue
 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="M" S DIFGER=12_U_DIFGY D ERROR^DIFG G X1 ;Lookup for entry failed (no earlier "add" since DIFGFLUS undefined - if DIFGFLUS defined, wouldn't have done ^DIC)
X1 K DIFGCHEK Q
 ;
KEY ;DETERMINE @LINK VALUE FROM KEY
 S DIFG("KEY","XREF")=""""_$P($P(DIFGDIX,U,3),"=")_"""",DIFG("KEY","VAL")=""""_$P(DIFGDIX,"=",2)_"""",DIFG("KEY","GLO")=^DIC(DIC,0,"GL")
 S Y=$O(@(DIFG("KEY","GLO")_DIFG("KEY","XREF")_","_DIFG("KEY","VAL")_","""")"))
 I Y="" S Y=-1 S DIFGER=13_U_DIFGY D ERROR^DIFG
 I 'DIFGER S (^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")),DIFGALNK)=Y,^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=X
 Q
 ;
LINK ;FINDS @NUMBER TO LINK DFN TO FROM LOOKUP
 I $F(DIFGDIX,"@") S DIFGSAVE(DIFG,"@NUM")="@"_+$E(DIFGDIX,$F(DIFGDIX,"@"),99) I $D(^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM"))) S DIFGFLUS=""
 ;Line before this checks if DIFG("@NUM") exists.  If it exists because it was a modify then don't need to do the lookup.
 ;If exists and is equal to itself (+^UTILITY("DIFG@",$J,"@NUM"))=0, then previous reference to this @link was an add and stll don't do lookup
 Q
 ;
ARRAY ;SETS EXECUTABLE ARRAY FOR DIC("S")
 F DIFGI=1:1 I '$D(DIFGDIC(DIC,DIFGI)) S DIFGI=DIFGI-1 Q
 S DIFGDIC(DIC,DIFGI)=DIFGDIC(DIC,DIFGI)_+Y,DIFGSVVL(DIFGCT)=+Y
 Q
 ;
IDENSPEC ;called from ^DIFG3
 S %=DIFGLAGO NEW DIFGLAGO S DIFGLAGO=$S(%=0:0,$D(DIFGENV("LAYGO",DIC,DIFGNUMF(DIFGCT))):1,DIFGHAT'["'":1,1:0) K %
 S DIFGSAVE(DIFG,"HX")=X,X=$P(DIFGDIX,"=",2) X DIFGLINE
 S DIFGSVVL(DIFGCT)="^UTILITY(""DIFG@"","_$J_",""@"_$P(DIFGDIX,"@",2)_""")" D RCR^DIFG3 G:DIFGER X
 S:$S($D(Y):Y<0,1:1) DIFGNOLK="" S X=DIFGSAVE(DIFG,"HX")
 D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY
X Q
 ;
DOLO ;called from ^DIFG3
 NEW %,%A
 S %A=$S($D(DIFGMGBL(DIFGMULT)):DIFGMGBL(DIFGMULT),1:^DIC(DIC,0,"GL"))
 F %=0:0 S %=$O(@(%A_"%)")) Q:'%  I +^(%,0)=X X DIC("S") I $T S DIFG("FOUND")="",Y=% Q
 I '$D(DIFG("FOUND")) S Y=-1
 Q
 ;
EOJ ;
 S DIFGEL=DIFGY
 S:$G(DIFGBSE)["^UTILITY" DIFGBSE="~"_$P(DIFGBSE,U,2,99) I 'DIFGER!(DIFGER&($S($D(DIFGBSE):$S(+DIFGBSE:1,1:@($TR($P(DIFGBSE,U),"~","^"))),1:0))) S @("DIFGY="_$TR($P(DIFGBSE,U),"~","^")_"_U_$P(DIFGBSE,U,2,3)")
 E  S DIFGY=-1
 I 'DIFGER K DIFGER
 I $D(DIFGREI),($D(DIFGEROR)!'$D(DIFGER)) S DA=DIFGREI,DIK="^DIAR(1.13," D ^DIK K DIK,DA
 K DIFGI,DIFGL,DIFGDIX,DIFGLO,DIFGEND,DIFGMULT,DIFGO,DIFGCT,DIFGEXC,DIFGLINE,DIFGALNK,DIFGSAVX,DIFG,DIFGBSE,DIFGDOL,DIFGNUMF,DIFGPC,DIFGPTER,DIFGVAL,DIFGKEY,DIFGMLND,DIFGDINM,DIFGREI,DIFGCHKG,DIFGEROR,DIFGLC,DIFGENV
 K ^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J),^UTILITY("DIFG",$J)
 Q

DIFG6
DIFG6 ;SFISC/DG(OHPRD)-UPDATE FILES ;2/3/93  12:23 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
 S DIFGORDR=0
 F DIFGL=0:0 S DIFGORDR=$O(^UTILITY("DIFG",$J,DIFGORDR)) Q:DIFGORDR=""!(DIFGER)  D SETVAR D:'$D(DIFGNODL) PROCESS K DIFGNODL
 D EOJ
 Q
 ;
SETVAR ;SET UP VARIABLES FOR DI* CALLS FOR A GIVEN ENTRY IN ^UTILITY("DIFG",$J,...)
 S DIFGFILE=$O(^UTILITY("DIFG",$J,DIFGORDR,0))
 S DIFGMODE=$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U)
 I DIFGMODE="D",^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=-1 S DIFGNODL="" G X3
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"X")) S:^("X")["^UTILITY" ^("X")="~"_$E(^("X"),2,$L(^("X"))) S X=$S($P(^("X"),U,2)'="N"!(+^("X")):$P(^("X"),U),1:@($TR($P(^("X"),U),"~","^")))
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA(1)")) F DIFGI=1:1 Q:'$D(^("DA("_DIFGI_")"))  S @("DA("_DIFGI_")="_^("DA("_DIFGI_")"))
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""P"")")) S DIC("P")=^("DIC(""P"")") ;Exists if a multiple and calling DIC to add
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")")) S DIC("DR")=^("DIC(""DR"")")
 ;I $D(DIC("DR")) S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")",DIFGZRO)) Q:'DIFGZRO  S DIC("DR"
X3 Q
 ;
PROCESS ;DETERMINE WHICH DI* ROUTINE(S) TO CALL FOR A GIVEN ENTRY
 I DIFGMODE="A" S DIC=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL") D CALLDIC^DIFG7 S:'DIFGER DIFGAVAL=+Y D:'DIFGER ADDCONT G X1
 D BUILDDR
 S DIE=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL"),@("DA="_^("DA")) I $D(DR),DR]"" D CALLDIE^DIFG7 I $D(Y) S DIFGER=14_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1
 I DIFGMODE="D",'DIFGER S DIK=DIE D CALLDIK^DIFG7
 I 'DIFGER S $P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"),"^",2)="I"
X1 K DIC,DIE,DIK,DA,DR,DIFGAVAL
 Q
 ;
ADDCONT ;CONTINUATION OF MODE="A" PROCESSING UPON RETURN FROM ^DIC
 S DA=DIFGAVAL,DIE=DIC
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_"^I" D ERROR^DIFG G X1
 D BUILDDR
 I $D(DR),DR]"" S DA=DIFGAVAL D CALLDIE^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=15_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG
 I 'DIFGER S @(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))=DIFGAVAL,^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=DIFGAVAL_"^I" D RESET
 Q
 ;
BUILDDR ;SET DR (BUILD DR ARRAY IF APPROPRIATE)
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR")) S DR=^("DR")
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR"))=11 S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR",DIFGZRO)) Q:'DIFGZRO  S DR(1,DIFGFILE,DIFGZRO)=^(DIFGZRO)
 Q
 ;
RESET ;RESETS MODE INDICATOR IN FILEGRAM FROM "A" TO "M"
 I DIFGORDR'<1 S DIFGTMP=DIFGLO_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_",0)",DIFGVL0=@DIFGTMP,DIFGVL1=$P(DIFGVL0,"="),DIFGVL2=$P(DIFGVL0,"=",2,3),$P(DIFGVL1,U,3)="M"
 E  G X2
 S DIFGTMP="^UTILITY(""DIFGFG"",$J,$P(^UTILITY(""DIFG"",$J,DIFGORDR,DIFGFILE,""MODE""),U,2))"
 S @(DIFGTMP_"=DIFGVL1_""=""_DIFGVL2")
 ;
X2 Q
 ;
EOJ K DIFGI,DIFGORDR,DIFGFILE,DIFGMODE,DIFGTMP,DIFGVL0,DIFGVL1,DIFGVL2,DIFGDRVL,DIFGDRPT,DIFGZRO
 Q

DIFG7
DIFG7 ;SFISC/DG(OHPRD)-CALLS TO DIC,DIE,DIK ;1/7/92  2:47 PM [ 03/13/96  7:58 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;IHS/TUCSON/LAB - 3/13/96 - modified this routine to pass back to
 ;the caller, an array, DIFGYFE(file,da) of all entries that were
 ;either added or edited during the filegram install
 ;it is the responsibility of the caller to kill DIFGYFE
CALLDIC ;
 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DINUM")) S DINUM=^("DINUM")
 S DIADD=1,DIC(0)="FLI" I $P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"X"),U,2)]"" S X="`"_X
 S DLAYGO=DIFGFILE
 S DITC=""
 D ^DIC
 K DITC
 I Y<1 S DIFGER=16_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG,K Q  ;IHS/TUCSON/LAB - 3/13/96 - added ,K Q so that if there is an error vars will get killed and then Q
 S DIFGYFE(DIFGFILE,+Y)=$P(Y,U,3) ;IHS/TUCSON/LAB - 3/14/96 - added this line to pass back to the caller, the ien,file of the entry added
K K DIADD,DLAYGO,DR,DINUM ;IHS/TUCSON/LAB - 3/13/96 - added line label K so this could be called
 Q
 ;
CALLDIE ;
 I DR[".01///"&($P(^DD(DIFGFILE,.01,0),U,5,99)["DINUM"!$D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DINUM"))) S DIFGDRVL=$P($P(DR,".01///",2),";"),DR=$P(DR,".01///"_DIFGDRVL)_$P(DR,".01///"_DIFGDRVL_";",2)
 NEW I F I=0:1 Q:'$D(@("D"_I))  K @("D"_I)
 S DITC=""
 D ^DIE K DITC
 I $G(DA),'$D(DIFGYFE(DIFGFILE,DA)) S DIFGYFE(DIFGFILE,DA)="" ;IHS/TUCSON/LAB - 03/13/96 - added this line to pass back ien,file that was edited
 Q
 ;
WP ;PROCESS WORD PROCESSING FIELD
 S DIFG("FIELD")=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",0)
 F DIFGI=1:1 Q:'$D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI))  D:^(DIFGI)[";" CHANGE S DR=DIFG("FIELD")_"///+"_^(DIFGI) D ^DIE
 K DR
 Q
 ;
CHANGE ;TEXT CONTAINS A ";"
 S DIFGSECP=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI) D PARSE^DIFG1 S ^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI)="^S X="_DIFGSECP
 Q
 ;
CALLDIK ;
 D ^DIK
 Q
 ;

DIFGA
DIFGA ;SFISC/XAK-FILEGRAM TEMPLATES ;3/5/93  1:22 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIC=DI,(DIPT,DC(0))=DA,DC(1)=0 D INIT^DIFGA1,GET^DIFGB,L S L=1,DE="",DJ=0
 K DNP Q
 ;
EN D INIT^DIFGA1 I $D(DIAX) G Q:Y'>0
L D RD I X=U!$D(DTOUT) G Q
 I X="",DL=1 D:DJ ^DIFGB D:$D(DIAXE01)&'(U[X) F1^DIAXMS G:(+$G(DIERR)&'(U[X)) ERR G Q
 I 'DJ,$E(X)="[" D TEM^DIFGB G Q:X=U
 D PR
 I $D(Y(0)),+$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S Y(0)=$P(Y,U,2) I $D(DIAX) S $P(Y(0),U,2)=$P(^(0),U,2)
 D:$D(Y) ST G Q:$D(DIRUT)
 I DINS,DINS<DL S DINS(DINS)=DC,DC=0,DINS=""
 G L
ERR W !!,$C(7),"THE DESTINATION FILE DATA DICTIONARY SHOULD BE MODIFIED PRIOR TO ANY MOVEMENT",!,"OF EXTRACT DATA!"
Q G Q^DIFGA1
 ;
RD ;
 S DU=$P(^DD(DK,0),U) S:DU="FIELD" DU=$O(^(0,"NM",0))_" "_DU
 W !?DL+DL-2 W $S(DJ:" THEN",1:"FIRST")_$S($D(DIAX):" EXTRACT ",1:" SEND ")_DU_": "
 G 1:'DC
 D:'$D(DC(DC)) GET^DIFGB G 1:'DC W $P(DC(DC),U)
 I $L($P(DC(DC),U))>19 S Y=$P(DC(DC),U) D RW^DIR2 G 2
 I DC(DC)]"" W "// "
1 R X:DTIME I '$T S DTOUT=1 Q
2 Q:'DC  S DINS=X?1"^"1.E,X=$S(DINS:$E(X,2,999),X="":$P(DC(DC),U),1:X) S:DC(DC)=""&$L(X) DINS=1 S:DINS DINS=DL
 Q
PR ;
 S (S,DM,DIFG,DIFGLINK)="" K DIC,Y
 I X="" D UP Q
 I X?1"""".E1"""".E G QQ
 I X="ALL",'DJ W "  Do you mean ALL the fields in the file" S %=2 D YN^DICN S Y=$S(%<0:"",%=1:"ALL",1:%) Q:X[Y  W !?10,X
 S DIC="^DD(DK,",DIC(0)="ZE"_$E("O",DC>0),DIC("W")="W:$P(^(0),U,2) ""  (multiple)"""
 S DIC("S")=$S('$D(DIAX):"I $P(^(0),U,2)'[""C""",1:"") S:$D(DICS) DIC("S")=DIC("S")_" X DICS"
 D ^DIC Q:Y>0  I X?1"?".E K Y Q
 I DC,X="@" D DC K Y Q
 S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)),'$D(DIAX) D IX^DIC Q:$D(Y)=11
 G:X'?.E1":" QQ
 I $L(X,":")>2 S %=$O(^DD(DK,"B",$P(X,":"),0)) G:'% QQ G:$P(^DD(DK,%,0),U,2)'["C" QQ
 S DM=X,DQI="DIP(",DA="",DICOMP=DIL_$E("?",''L)_"T"
 S (DICOMPX,DICMX)="",DIFG=$S($L(X,":")>2:5,1:1) D ^DICOMPW G:'$D(X) QQ
 S:+DIFG("DICOMP")=DK DM=$P(^DD(DK,+$P(DIFG("DICOMP"),U,2),0),U,1)_":" S:DIFG?1A.E DIFGLINK=DIFG,DIFG=4 Q
ST ;
 I $D(DIAX),Y="ALL" W !,$C(7),"SORRY, THIS FUNCTIONALITY IS NOT SUPPORTED AT THIS TIME." Q
 I Y="ALL" D N S DJ=DJ+1 K DIFGALL Q
 I 'Y,$D(Y)=11 F Y=0:0 S Y=$O(Y(Y)) Q:Y'>0  S X=^DD(DK,Y,0) D Y
 Q:Y'>0
 I $D(DIAX),$D(Y)=11,$P(Y(0),U,2)["m" W !,$C(7),"SORRY, CANNOT EXTRACT THIS TYPE OF COMPUTED FIELD AT THIS TIME." Q
 I DIFG]"" S %=Y,S=U_$P(DP,U,2)_U_S,X=1 D D1 S DK=+DP,Y=0,DIL=+% D Y Q
 I $P(Y(0),U,2) S DM=$P(Y(0),U) D D,Y S X=$P($P(Y(0),U,4),";"),I(DIL)=$S(+X=X:X,1:$C(34)_X_$C(34)),J(DIL)=DK Q
 S Y=+Y D Y
 Q
 ;
D D D1 S DK=+$P(^DD(DK,+Y,0),U,2),DIL=DIL+1,Y=0,DIFG=3 Q
D1 S DJ1(DL)=DJ,DIL(DL)=DIL,DJ=0,C(DL)=C,DL(DL)=DK,DL=DL+1,(C,C(0))=C(0)+1
 Q
 ;
U S DL=DL-1,C=C(DL),DK=DL(DL),DIL=DIL(DL) S:$D(DIAX) (DIAXF,DIAXFILE)=DIAXDL(DL) S DJ=$S(DJ&'DJ1(DL):1,1:DJ1(DL)) K:DL=1 DIAXSB
 I $D(DINS(DL)) S DC=DINS(DL)-1 K DINS(DL)
 F %=DIL:0 S %=$O(I(%)) Q:%'>0  K I(%),J(%),DJ1(%)
 Q
 ;
DC I 'DINS K:DC>1 DC(DC) D DC1 S DC=DC+1
 Q
DC1 Q:(X'="@"!(DC'=2))  S DC=DC+1
 F  Q:'$D(DC(DC))  K DC(DC) S DC=DC+1
 S DC=DC-2 Q
 ;
Y S S=Y_S
DJ I $D(DIAX) D DIAX Q
 I C,'DJ1(DL-1) S:'$D(^UTILITY("DIFG",$J,C-1)) ^(C-1)=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U
 I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK
 S:$D(DIFGALL) $P(^UTILITY("DIFG",$J,C),U,8)=1
 S:S DJ=DJ+1,^(C,DJ)=S S S="" D DC:DC Q
 ;
N S I=DL,DM="ALL",DIFGALL=1 D Y S DM=""
NN S Y=.001 ;I $D(^DD(DK,Y)) D Y
A S Y=$O(^DD(DK,Y)) I $D(^(Y,8)),$D(DICS) X DICS E  G A
 I Y'>0 G UP:I'<DL D U S Y=Y(DL) G A
 I $P(^(0),U,2) G A:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W" S Y(DL)=Y D D,Y G NN
 G A ;D Y G A
 ;
UP K DIC I DL>1 D U,DC:DC
 Q
 ;
QQ W $C(7)," ??" K Y Q
 ;
DIAX I 'S,$G(DIFG)>2 S DIAXDICA=$S(DIFG=3:Y(0,0),1:DM) D ^DIAXMS I $D(DIAXUP) D UP K DIAXUP,DIAXSB Q
 S DIAXDK(DK)=DIAXF,DIAXDL(DL)=DIAXF
 I C,'$D(^UTILITY("DIFG",$J,C(DL-1))) S ^(C(DL-1))=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U_U_U_DIAXDL(DL-1)_U_DIAXDK(DL(DL-1)),DIAXE01(DIAXDL(DL-1))=(DL-1)_U_$G(DIAXSB)
 I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK_U_U_DIAXF_U_$S(DL>1:DIAXDK(DL(DL-1)),1:DIAXF)_U_$G(DIAXNP(DL-1)),DIAXE01(DIAXF)=DK_U_$G(DIAXSB)
 I S D EN2^DIAXM Q:$D(DIRUT)
 S S="" D DC:DC W ! Q

DIFGA1
DIFGA1 ;SFISC/XAK,DCM-FILEGRAM TEMPLATES ;2/10/93  3:43 PM
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
Q W:$D(DTOUT) *7
 K Y,C,L,DM,DQI,DA,DICOMP,DICOMPX,I,J,S,DIL,DK
 K D,DIFG,DC,DICS,DP,DU,DXS,DL,DJ,DINS,DIFGLINK
 K DIAXLOC,DIAXMSG,DIAXGL,DIAXF,^UTILITY("DIFG",$J),DJ1,DIAXEF,DIAXDL,DIAXDI,DIAXFILE,DIAXFNO
 K DIAXDICA,DIAXNP,DIAXZ,DIAXDK,DTOUT,DUOUT,DIRUT
 D:$D(DIAX) Q1^DIAXMS
 Q
 ;
INIT K ^UTILITY("DIFG",$J)
 S (L,DL)=1,(I(0),DI)=DIC,(DK,J(0))=+$P(@(DI_"0)"),U,2)
 S DINS="",(DC,DJ,C,C(0),DIL)=0 Q:'$D(DIAX)
 ;
INET K DIC
 S DIC=1,DIC(0)="AEQZ",DIC("S")="I Y'<2,+Y'="_DK_" S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %",DIC("A")="DESTINATION FILE: " D ^DIC Q:Y'>0
 S (DIAXF,DIAXFILE,DIAXFNO,DIAXDL(DL),DIAXDK(DK))=+Y,DIAXGL=$E(^DIC(+Y,0,"GL"),2,99),DIAXEF=Y(0,0),DIAXLOC(DIAXFILE)=""
 Q

DIFGB
DIFGB ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96  11:16
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PUT ;
 W !,"STORE ",$S($D(DIAR):"ARCHIVE",$D(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: "
 R X:DTIME S:'$T DTOUT=1,X="" G Q:U[X
 S DIC="^DIPT(",D="F"_DK
 S DIC("S")="S %=^(0) I $P(%,U,8)="_$S($D(DIAX):2,1:1)_",$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&L)
 S DIC(0)="ELZSQI",DIC("S")="I Y'<1 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q
 S S=$O(^DIPT(+Y,0))]""
 I S W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 D PURGE
 S ^DIPT(+Y,0)=$P(Y,U,2)_U_DT_U_DUZ(0)_U_DK_U_DUZ_U_DUZ(0)_U_DT,^DIPT("F"_DK,$P(Y,U,2),+Y)=1
 I '$D(DIAX) S ^DIPT("FG",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8)=1
 E  S $P(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO
 S Y=+Y,%X=""
 F %=1:1 S %X=$O(^UTILITY("DIFG",$J,%X)) Q:%X=""  S ^DIPT(Y,1,%,0)=^(%X) D FLD
 S:%-1 ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1)
 I '$D(DIAX) S ^DIPT(Y,"F",2)="S DIFGT="""_$P(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X"
Q K ^UTILITY("DIFG",$J),DIFG Q
 ;
PURGE L +^DIPT(+Y)
 S %Y=0 F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y=""  K:%Y'="%D" ^DIPT(+Y,%Y)
 L -^DIPT(+Y)
 Q
 ;
W S %=$P(^DIPT(+Y,0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q
 Q
 ;
FLD S %Y=""
 F S=1:1 S %Y=$O(^UTILITY("DIFG",$J,%X,%Y)) Q:%Y=""  S ^DIPT(Y,1,%,"F",S,0)=^(%Y)
 S:S-1 ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1) Q
 ;
TEM ;
 S X=$E(X,2,99),DIC="^DIPT(",DIC(0)="SQEM",D="FG" I X["?"!($D(DIAX)) S D="F"_DK
 S DIC("S")="I $P(^(0),U,4)="_DK_",$P(^(0),U,8)="_$S($D(DIAX):2,1:1)_$S($D(DIAX):",$P(^(0),U,9)=DIAXFNO",1:"")
 D IX^DIC S X="" Q:Y<0
EN ;
 K DIR S DA=+Y
 S DIR(0)="Y",DIR("A")="WANT TO EDIT '"_$P(Y,U,2)_"' TEMPLATE"
 D ^DIR K DIR S:'Y!$D(DTOUT) X=U Q:'Y  D DIE I '$D(DA) S DC=0 Q
 S DC(1)=0,DC(0)=DA K DA D GET
 S DJ=0,X="" ;D EN^DIFGA,PUT:X'=U
 Q
GET S DC(1)=$O(^DIPT(DC(0),1,+DC(1))),DC=0 Q:+DC(1)'=DC(1)
 S %=^(DC(1),0),X=+% Q:'X  S DC=1
 I DL>1,$P(%,U,2)'>DL F J=$P(%,U,2):1:DL S DC=DC+1,DC(DC)=""
 I $D(DIAX),$P(%,U,4)>2 S $P(DC(1),U,3)=$O(^DD(+$P(%,U,9),0,"NM",""))
 I $P(%,U,5)]"" S DC=DC+1,DC(DC)=$P(%,U,5)
 F J=0:0 S J=$O(^DIPT(DC(0),1,+DC(1),"F",J)) Q:+J'=J  S %=^(J,0),DIAXZ=$P(%,U,2,9),%=+%,%=$S($D(^DD(X,%,0)):$P(^(0),U),1:%) S:'% DC=DC+1,DC(DC)=%_U_DIAXZ
 S DC=$S($D(DC(2)):2,1:0)
 Q
DIE N DL,DK,DI
 S DIE="^DIPT(",DR=".01;3;6" D ^DIE K DIE,DR S X=""
 Q
FG ;Entry from Print template
 K ^UTILITY($J,"W")
 S DIFG("FE")=D0,DIFG("FUNC")="L",DIFG("FGR")="^UTILITY(""DIFG"",$J,"
 I 'DIFGT S DIC="^DIPT(",D="FG",DIC("S")="I $P(^(0),U,4)="_DIFGBFN,DIC(0)="O",X=DIFGT K DIFGBFN D IX^DIC S:+Y DIFGT=+Y I Y'>0 K DIFG,DIFGT G Q
 I $G(DIAR)=4 S DIFG("FGR")="^DIAR(1.11,DIARC,""D""," I DIARF=DIARF2,$D(^DIC(+DIARF,0,"GL")) S D1=^("GL"),@(D1_"D0,-9)")=DIARC
 I $G(DIARP)]"",+DIARP'=+DIFGT S DIFGT=DIARP,^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X"
 N DI,D0 D START^DIFGG
 I $D(DIARD) S DIARD=DIARD+1 W:(DIARD#50=0) !,DIARD," RECORDS PROCESSED"
 I $G(DIAR)=4 S ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC Q
 S DIWL=1,DIWR=IOM-1,DIWF="NW"
 F D1=0:0 S D1=$O(^UTILITY("DIFG",$J,D1)) Q:D1'>0  S X=^(D1,0) D ^DIWP Q:'DN
 D:DN ^DIWW G Q
WR F D1=0:0 S D1=$O(^DIAR(1.11,DIARC,"D",D1)) Q:D1'>0  S X=^(D1,0) W X
 G Q

DIFGG
DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92  2:15 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DIFG S DIFG=DIC,DIC("A")="Select FILEGRAM TEMPLATE: "
 S DK=+Y,DIC="^DIPT(",DIC("S")="I $P(^(0),U,8)=1 S %=^(0) I $P(%,U,4)=DK!'$L($P(%,U,4))",DIC(0)="QEAIS",D="F"_+Y
 D IX^DIC K DIC,DY Q:Y<0  S (DIFG("TEMPLATE"),DIFGT)=+Y
 S DIC=DIFG,DIC(0)="QEAM" D ^DIC Q:Y<0  S DIFG("FE")=+Y,DIFG("FUNC")="L",DIFG("DUZ")=$S($D(^VA(200,DUZ,0)):$P(^(0),U),$D(^DIC(3,DUZ,0)):$P(^(0),U),1:DUZ)
 D START,SEND,LOG K DIFG,^UTILITY("DIFG",$J) Q
 ;
EN ; EXTERNAL ENTRY POINT
START ;
 D INIT
 I DIFG("QFLG") D EOJ Q
 D HDR,ENV,BODY,TLR,EOJ
 Q
 ;
HDR ; FILEGRAM HEADER
 S V="$DAT"_U_DIFG(DILL,"FNAME")_U_DIFG(DILL,"FILE")_U_DIFG("PARM")_U
 D INCSET^DIFGGU
 K Y Q
 ;
ENV ; ENVIRONMENTAL VARS
 I $D(DIFG("ENV"))
 E  Q
 S DIFG("EV")=""
 F  S DIFG("EV")=$O(DIFG("ENV",DIFG("EV"))) Q:DIFG("EV")=""  S V="ENVIRONMENT:"_DIFG("EV")_"="""_DIFG("ENV",DIFG("EV"))_"""" D INCSET^DIFGGU ;ihs/ohprd/dg;patch 2;8-22-91
 K DIFG("EV") Q
 ;
BODY ; FILEGRAM BODY
 D BASE
 K DIFG("NOKEY")
 D NEXTLVL
 Q
 ;
BASE ; BASEFILE ENTRY
 D LOOKUP^DIFGGU
 D FIELDS
 Q
 ;
NEXTLVL ; DO NEXT LEVEL FILES/SUBFILES (CALLED RECURSIVELY)
 S DIFG(DILL,"DIFGI")=DIFGI
 S DILL=DILL+1
 F DIFGI=DIFGI:0 S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI  S X=^(DIFGI,0) D NEXTLVL2 Q:DIFGI=""
 S DILL=DILL-1
 S DIFGI=DIFG(DILL,"DIFGI")
 Q
 ;
NEXTLVL2 ; CHECK TEMPLATE ENTRY
 I $P(X,U,2)<DILL S DIFGI="" Q
 Q:$P(X,U,3)'=DIFG(DILL-1,"FILE")  ; this is probably a template error
 D FVARS^DIFGGI
 I DIFG(DILL,"XREF")?1A.E D DIFGG3^DIFGG4 Q  ; file shift
 I DIFG(DILL,"XREF")=3 D ^DIFGG4 Q  ; subfile shift
 Q:'DIFG(DILL,"FE")
 ; only things left are dinum back pointers, direct forward pointers,
 ; and lookup file shifts, I think.
 D LOOKUP^DIFGGU
 I $D(DIFGGUQ) K DIFGGUQ Q
 D FIELDS
 D RECURSE
 S DITAB=2*(DILL-1)
 S V=":" D INCSET^DIFGGU
 Q
 ;
RECURSE ; RECURSION FOR DINUM BACK POINTERS AND FORWARD DIRECT POINTERS
 D NEXTLVL
 Q
 ;
FIELDS ; FILEGRAM FIELDS
 S DITAB=DITAB+2 D ^DIFGG2 S DITAB=DITAB-2
 Q
 ;
LOG ; RECORD THE SENDING
 Q:$D(DIAR)!$D(DY)
 S DIC=1.12,X="NOW",DIC(0)="L",DLAYGO=1.12,DIADD=1 D ^DIC Q:Y<0  G LOG:'$P(Y,U,3)
 S ^DIAR(1.12,+Y,0)=$P(Y,U,2)_"^s^"_DIFG("DUZ")_U_DIFG_U_DIFG("FE")_U_XMZ_U_DIFG("TEMPLATE")
 K DIC,DIE,DR,DA,DLAYGO,DIADD,XMZ
 Q
 ;
 ;
SEND ; CALL MAILMAN
 Q:$D(DIAR)!$D(DY)
 S XMSUB="FILEGRAM for entry #"_DIFG("FE")_" in "_$O(^DD(DIFG,0,"NM",0))_" FILE (#"_DIFG_")."
 S XMTEXT=DIFG("FGR"),XMDUZ=DUZ D ^XMD
 Q
 ;
TLR ; FILEGRAM TRAILER
 S V="$END DAT",DITAB=0
 D INCSET^DIFGGU
 Q
 ;
INIT ; INITIALIZATION
 D ^DIFGGI
 Q
 ;
EOJ ;
 S:DIFG("QFLG") DIFGER=DIFG("QFLG")
 F I=0:0 S I=$O(DIFG(I)) Q:I'=+I  K DIFG(I)
 K ^UTILITY("DIFGLINK",$J)
 K DIFG2,DIFGI,DIFGT,DILL,DITAB,DIFGENV,DIFGGU,DIFGGF ;Don't kill DILC used by EN^DIFGG;ihs/ohprd/dwg;patch 2;8-22-91
 K %H,%K,%W,S,V,X
 Q

DIFGG2
DIFGG2 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM FIELDS ;2/4/93  10:59 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 D DRS
 K S,V,X,DIFG2
 Q
 ;
DRS S DR=""
 I $P(^DIPT(DIFGT,1,DIFGI,0),U,8) F DIFG2=.001:0 S DIFG2=$O(^DD(DIFG(DILL,"FILE"),DIFG2)) Q:DIFG2'>0  S %=$P(^(DIFG2,0),U,2) I $S('%:%'["C",1:$P(^DD(+%,.01,0),U,2)["W") S DR=DR_DIFG2_";" I $L(DR)>200 D DR S DR=""
 F DIFG2=0:0 S DIFG2=$O(^DIPT(DIFGT,1,DIFGI,"F",DIFG2)) Q:DIFG2'=+DIFG2  I $D(^(DIFG2,0)) S DR=DR_^(0)_";" I $L(DR)>200 D DR S DR=""
 D DR:DR]"" Q
 ;
EN ;
DR I '$D(DIFG(DILL,"MUL")) S DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE")
 S DIQ(0)="N" D EN^DIQ1 K DIQ
 I $D(DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) F DIFG2(DILL,"FLD")=0:0 S DIFG2(DILL,"FLD")=$O(DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))) Q:'DIFG2(DILL,"FLD")  D
 . NEW VAL
 . S VAL=DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))
 . S ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))=$S(VAL]"":VAL,1:"^")
 . Q
 F DIFG2(DILL,"FLD")=0:0 D DR2 Q:DIFG2(DILL,"FLD")'=+DIFG2(DILL,"FLD")  S V=^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD")) D FIELD
 I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")),DIFGGF(DIFG(DILL,"FILE"))
 Q
 ;
DR2 S DIFG2(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))) Q:DIFG2(DILL,"FLD")=""
 I $O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"),0)) S V("WP")=0,^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))="wp"
 Q
 ;
EN2 ;
FIELD Q:V=""
 D SETXY
 K F,N,P,W
 S V=$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,1)_U_$S(DIFG("PARM")["N":DIFG2(DILL,"FLD"),1:"")_"="_X
 D INCSET^DIFGGU
 D:Y'="" PTRCHK
 D:$D(V)>9 WP
 K X,Y,V
 Q
 ;
WP NEW I
 S DITAB=DITAB+2
 S DIFG("WP")=""
 F I=0:0 S I=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"),I)) Q:I=""  S V=""""_^(I)_"""" D INCSET^DIFGGU
 S V="." D INCSET^DIFGGU
 K DIFG("WP")
 S DITAB=DITAB-2
 Q
 ;
SETXY S X=V
 S Y=""
 Q:$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2)'["P"
 S F=+$P($P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2),"P",2),W=$P(^(0),U,4),N=$P(W,";",1),P=$P(W,";",2)
 S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P)
 I $D(^UTILITY("DIFGLINK",$J,F,Y)) S X="@"_^UTILITY("DIFGLINK",$J,F,Y),Y="" Q
 S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1)
 S ^UTILITY("DIFGLINK",$J,F,Y)=^UTILITY("DIFGLINK",$J)
 S Y="@"_^UTILITY("DIFGLINK",$J)
 Q
 ;
PTRCHK Q:$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2)'["P"
 S DITAB=DITAB+2
 S DILL=DILL+1
 D POINTER
 S DITAB=DITAB-2
 K DIFG(DILL)
 S DILL=DILL-1
 Q
 ;
POINTER S DIFG(DILL,"FILE")=+$P($P(^DD(DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD"),0),U,2),"P",2),X=$P(^(0),U,4) S:$P(X,";")'=+X X=""""_$P(X,";")_""";"_$P(X,";",2)
 S DIFG(DILL,"FE")=$P(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_$P(X,";",1)_")"),U,$P(X,";",2))
 I '$D(^DIC(DIFG(DILL,"FILE"),0)) D KILLLL^DIFGGU Q
 S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL")
 I '$D(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)")) D KILLLL^DIFGGU Q
 S DIFG(DILL,"FNAME")=$P(^DIC(DIFG(DILL,"FILE"),0),U,1)
 I $D(Y),Y'="" S Z=Y,Y=""
 I $D(DIFGENV("LAYGO",DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD")))!($P(^DD(DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD"),0),U,2)'["'") S DIFG(DILL,"NOKEY")=""
 D ^DIFGGSB
 Q

DIFGG4
DIFGG4 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SUBFILES ;6/10/93  1:41 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SUBFILE ; DO ONE SUBFILE
 F DIFG(DILL,"FE")=0:0 S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_")")) Q:DIFG(DILL,"FE")'=+DIFG(DILL,"FE")  D SUBENTRY
 Q
 ;
SUBENTRY ; DO ONE SUBFILE ENTRY
 D DIS Q:'$T
 D DR S DR(DIFG(DILL,"FILE"))=.01
 S DIFG(DILL,"MUL")=1
 D LOOKUP^DIFGGU
 I $D(DIFGGUQ) K DIFGGUQ,DIFG(DILL,"MUL") Q
 D DR,DRS
 D RECURSEM
 S V="^" D INCSET^DIFGGU
 K DIFG(DILL,"MUL"),DA,DR
 Q
 ;
DR ; CREATE DR-STRINGS
 K DR S I=0
 F %=DIFG(DILL,"FILE"):0 Q:'$D(^DD(%,0,"UP"))  S X=^("UP"),Y=$O(^DD(X,"SB",%,0)),DR(X)=Y,DA(%)=DIFG(DILL-I,"FE"),%=X,I=I+1
 S DA=DIFG(DILL-I,"FE"),DIC=DIFG(DILL-I,"FILE"),DR=DR(%) K DR(%)
 Q
 ;
DRS ; PROCESS ALL DR STRINGS FOR FILE
 S DR(DIFG(DILL,"FILE"))="",DITAB=DITAB+2
 I $P(^DIPT(DIFGT,1,DIFGI,0),U,8) F DIFG2=.001:0 S %=DIFG(DILL,"FILE"),DIFG2=$O(^DD(%,DIFG2)) Q:DIFG2'>0  D DRA
 F DIFG2=0:0 S DIFG2=$O(^DIPT(DIFGT,1,DIFGI,"F",DIFG2)) Q:DIFG2'=+DIFG2  I $D(^(DIFG2,0)) S DR(DIFG(DILL,"FILE"))=DR(DIFG(DILL,"FILE"))_^(0)_";" I $L(DR(DIFG(DILL,"FILE")))>200 D EN^DIFGG2 S DR(DIFG(DILL,"FILE"))=""
 D EN^DIFGG2:DR(DIFG(DILL,"FILE"))]""
 S DITAB=DITAB-2
 Q
 ;
DRA ;Process all subfields
 S %1=$P(^(0),U,0) I $S('%1:%1'["C",1:$P(^DD(+%1,.01,0),U,2)["W") S DR(%)=DR(%)_DIFG2_";" I $L(DR(%))>200 D EN^DIFGG2 S %=DIFG(DILL,"FILE"),DR(%)=""
 Q
 ;
DIS ; SCREEN THIS ENTRY
 F %=1:1:DILL S @("D"_(%-1))=DIFG(%,"FE")
 I $D(DIFG(DIFG(DILL,"FILE"),"S"))#2 X DIFG(DIFG(DILL,"FILE"),"S") Q
 I 1 Q
 ;
RECURSEM ; RECURSION FOR DEEPER SUBFILE SHIFTS
 S DITAB=DITAB+2
 D NEXTLVL^DIFGG
 S DITAB=DITAB-2
 Q
 ;
 ;
DIFGG3 ; FILEGRAM NAVIGATION
 ; SEE DIFGG3^DIFGGDOC
 ;
FILE ; PROCESS ONE FILE
 F DIFG(DILL,"FE")=0:0 D FILE2 Q:DIFG(DILL,"FE")=""  D ENTRY
 K I,S,V,X
 Q
 ;
FILE2 ;
 S X=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),0))
 Q:'X
 S Y=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),X,0))
 Q:'Y
 I $P(^DD(X,Y,0),U,2)["V" S DIFG(DILL,"FSV")=""""_DIFG(DILL-1,"FE")_";"_$P(^DIC(DIFG(DILL-1,"FILE"),0,"GL"),U,2)_"""" I 1
 E  S DIFG(DILL,"FSV")=DIFG(DILL-1,"FE")
 S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_""""_DIFG(DILL,"XREF")_""","_DIFG(DILL,"FSV")_","_DIFG(DILL,"FE")_")"))
 Q
 ;
ENTRY ; PROCESS ONE FILE ENTRY
 S DIFG(DILL,"NAV")=1
 D LOOKUP^DIFGGU
 K DIFG(DILL,"NAV")
 I $D(DIFGGUQ) K DIFGGUQ Q
 S DITAB=DITAB+2
 D ^DIFGG2
 D RECURSEF
 S DITAB=2*(DILL-1)
 S V=":" D INCSET^DIFGGU
 Q
 ;
RECURSEF ; RECURSION FOR DEEPER FILE SHIFTS
 D NEXTLVL^DIFGG
 Q

DIFGGI
DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93  9:45 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; DIFGER values: 1 = required variable not passed
 ;                2 = variable form invalid
 ;                3 = variable content invalid
 ;
INIT ; INITIALIZATION
 K ^UTILITY("DIFG",$J),^UTILITY("DIFGLINK",$J)
 D SET1,REQ Q:DIFG("QFLG")
 D OPT Q:DIFG("QFLG")
 D FIRST
 Q
 ;
SET1 ; MISC SETS # 1
 S DIFGI=0,DILL=1 K DIFGER S U="^",DIFG("QFLG")=0
 Q
 ;
REQ ;
 ;
FE I '$D(DIFG("FE")) S DIFG("QFLG")=1 Q
 I DIFG("FE")'=+DIFG("FE") S DIFG("QFLG")=2 Q
FUNC I '$D(DIFG("FUNC")) S DIFG("QFLG")="1" Q
 I DIFG("FUNC")="" S DIFG("QFLG")=2 Q
 I "AMLD"'[DIFG("FUNC") S DIFG("QFLG")=3 Q
FGT I '$D(DIFGT) S DIFG("QFLG")=1 Q
 I DIFGT'=+DIFGT S DIFG("QFLG")=2 Q
 I '$D(^DIPT(DIFGT,0)) S DIFG("QFLG")=3 Q
 Q
 ;
OPT ;
 ;
FGR I '$D(DIFG("FGR")) S DIFG("FGR")="^UTILITY(""DIFG"",$J,"
 S X=DIFG("FGR")
 I "(,"'[$E(X,$L(X)) S DIFG("QFLG")=2 Q
 I $P(X,"(")["DIFG" S DIFG("QFLG")=3 Q
LC I $D(DILC),DILC'=+DILC S DIFG("QFLG")=2 Q
 S:'$D(DILC) DILC=0
PARM S:'$D(DIFG("PARM")) DIFG("PARM")="N"
TAB I $D(DITAB),DITAB'=+DITAB S DIFG("QFLG")=2 Q
 S:'$D(DITAB) DITAB=0
FUNCSFT I $D(DIFG("FUNC SFT")) F X=0:0 S X=$O(DIFG("FUNC SFT",X)) Q:X'=+X  D FUNCSFT2 Q:DIFG("QFLG")
 Q
 ;
FUNCSFT2 S Y=DIFG("FUNC SFT",X)
 I Y="" S DIFG("QFLG")=2 Q
 I "AMLD"'[Y S DIFG("QFLG")=3 Q
 Q
 ;
FIRST ; GET PRIMARY FILE VARIABLES
 S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI  S X=^(DIFGI,0)
 D FVARS
 I '$D(@(DIFG(DILL,"FGBL")_DIFG("FE")_",0)")) S DIFG("QFLG")=3 Q
 Q
 ;
FVARS ; SETUP FILE VARIABLES
 S DILL=$P(X,U,2),DITAB=2*(DILL-1),DIFG(DILL,"FILE")=+X
 S DIFG(DILL,"FNAME")=$O(^DD(DIFG(DILL,"FILE"),0,"NM",0))
 I DILL=1 S DIFG(DILL,"FE")=DIFG("FE"),DIFG(DILL,"FUNC")=DIFG("FUNC")
 E  S DIFG(DILL,"FUNC")=DIFG(DILL-1,"FUNC")
 I $D(DIFG("FUNC SFT",DIFG(DILL,"FILE"))) S DIFG(DILL,"FUNC")=DIFG("FUNC SFT",DIFG(DILL,"FILE"))
 I $P(X,U,4)=1 S DIFG(DILL,"FE")=DIFG(DILL-1,"FE") ; dinum back pointer
 S DIFG(DILL,"XREF")=$S($P(X,U,4)=4:$P(X,U,7),1:$P(X,U,4)),%=$P(X,U,5) ;Back pointer if $P=4 X-ref in $P7
 I $E(%,$L(%))=":" S DIFG(DILL,"NAV")=1 I $P(X,U,4)=2 S DIFG(DILL,"NAV")=2 D DIRECT K %,Y
 I $P(X,U,4)=3 S %=$P(X,U,3),%=$O(^DD(%,"SB",+X,0)),%=^DD(+$P(X,U,3),%,0),%=$P($P(^(0),U,4),";") S:+%'=% %=""""_%_"""" S DIFG(DILL,"FGBL")=DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%_"," K DIFG(DILL,"NAV") Q  ; multiple
 S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL")
 D:$P(X,U,4)=5 LOOKUP
 Q
 ;
DIRECT ;DIRECT POINTER
 S DIFG(DILL,"FE")=0,%=$P(%,":")
 S:'$D(^DD(DIFG(DILL-1,"FILE"),"B",%)) %=$O(^(%))
 S %=$O(^DD(DIFG(DILL-1,"FILE"),"B",%,0))
 Q:%'=+%
 S Y=$P(^DD(DIFG(DILL-1,"FILE"),%,0),U,4),%("N")=$P(Y,";"),%("P")=$P(Y,";",2) S:+%("N")'=%("N") %("N")=""""_%("N")_""""
 I $D(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%("N")_")")) S Y=@("^("_%("N")_")"),DIFG(DILL,"FE")=$P(Y,U,%("P"))
 Q
 ;
LOOKUP ;COMPUTED FIELD LOOKUP FOR FILE SHIFT
 S DIFG(DILL,"FE")=""
 S %=$O(^DD(DIFG(DILL,"FILE"),"B",$P($P(X,U,5),":"),0))
 Q:'%
 X $P(^DD(DIFG(DILL,"FILE"),%,0),U,5,99)
 I $D(X) S DIFG(DILL,"FE")=$S(X?1"`"1N.N:$E(X,2,99),X?1N.N:X,1:"")
 Q

DIFGGSB
DIFGGSB ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;EDE/OHPRD/IHS changed BEGEN/END line to match BNF
 ;
START ; (CALLED RECURSIVELY)
 K DIFGSB(DILL)
 D BEGIN
 S DITAB=DITAB+2
 D BODY^DIFGGSB1
 S DITAB=DITAB-2
 D END,EOJ
 Q
 ;
BEGIN ; BEGIN LINE
 S V="BEGIN:"_DIFG(DILL,"FNAME")_"^"_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"")
 I $D(Z),Z'="" S V=V_Z,Z=""
 D INCSET^DIFGGU
 Q
 ;
 ;
END ; END LINE
 S V="END:"_DIFG(DILL,"FNAME")_"^"_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"")
 D INCSET^DIFGGU
 Q
 ;
EOJ ;
 K DIFGSB(DILL)
 K %,C,D0,J,S,V,X,Y,Z
 Q

DIFGGSB1
DIFGGSB1 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK PART 2 ;2/3/93  12:46 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BODY S DIFGSB(DILL,"SPSPEC")=0
 I $D(DIFG(DILL,"FUNC")),"AL"[DIFG(DILL,"FUNC") I 1
 E  I $D(DIFG(DILL,"NOKEY"))
 E  D SPSPEC^DIFGGSB2
 Q:DIFGSB(DILL,"SPSPEC")
 D P01
 D SPEC
 D IDENT
 Q
 ;
P01 ; .01 FIELD WHEN IT IS A POINTER
 Q:$P(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P"
 S DIFGSB(DILL,"FLD")=.01
 D SETXY
 Q:Y=""
 D PTRCHK^DIFGGSB2
 Q
 ;
SPEC ; SPECIFIERS
 S DIFGSB(DILL,"SBT")="SPECIFIER:",%=""
 F DIFGSB(DILL,"FLD")=0:0 D SPEC2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")  S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
 I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1
 E  S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
 K % Q
 ;
SPEC2 S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD")))
 Q
 ;
IDENT ; IDENTIFIERS
 S DIFGSB(DILL,"SBT")="IDENTIFIER:",%=""
 F DIFGSB(DILL,"FLD")=0:0 D IDENT2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")  D:'$D(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD"))) IDENT3
 I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1
 E  S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
 K %
 Q
 ;
IDENT2 S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"ID",DIFGSB(DILL,"FLD")))
 Q
 ;
IDENT3 S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
 Q
 ;
FIELDS I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) D DRFIX
 I '$D(DIFG(DILL,"MUL")) Q:DR=""
 E  Q:DR(DIFG(DILL,"FILE"))=""
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 S:'$D(DIFG(DILL,"MUL")) DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE")
 S DIQ(0)="N" D EN^DIQ1 K DIQ
 F DIFGSB(DILL,"FLD")=0:0 D FIELDS2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")  S X=^(DIFGSB(DILL,"FLD")) D FIELDS3
 Q
 ;
DRFIX ; ADJUST DR FOR MODIFIED/DELETED VALUES
 NEW T
 I '$D(DIFG(DILL,"MUL")) S T=DR
 E  S T=DR(DIFG(DILL,"FILE"))
 F %=1:1 S X=$P(T,";",%) Q:X=""  S %(X)="" I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X)) K %(X) S DIFGSB(DILL,"FLD")=X,X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X) D DRFIX2
 S (T,X)=""
 F %=0:0 S X=$O(%(X)) Q:X=""  S T=T_$S(T="":"",1:";")_X
 I '$D(DIFG(DILL,"MUL")) S DR=T
 E  S DR(DIFG(DILL,"FILE"))=T
 Q
 ;
DRFIX2 NEW %,DR,T
 D FIELDS3
 Q
 ;
FIELDS2 S DIFGSB(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD")))
 Q
 ;
FIELDS3 Q:X=""
 D SETXY
 K F,N,P,W
 S V=DIFGSB(DILL,"SBT")_$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,1)_U_$S(DIFG("PARM")["N":DIFGSB(DILL,"FLD"),1:"")
 S:DIFGSB(DILL,"SBT")["KEY" V=V_U_$P(DIFGSB(DILL,"SPSPEC"),U,2)
 S V=V_"="_X
 D INCSET^DIFGGU
 D:Y'="" PTRCHK^DIFGGSB2
 K X,Y
 Q
SETXY ; If previously looked up pointer set @LINK
 S Y=""
 Q:$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P"
 S F=+$P($P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2),"P",2),W=$P(^(0),U,4),N=$P(W,";",1),P=$P(W,";",2)
 I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P")) S Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P") I 1
 E  S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P)
 I $D(^UTILITY("DIFGLINK",$J,F,Y)) S X="@"_^UTILITY("DIFGLINK",$J,F,Y),Y="" Q
 S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1)
 S ^UTILITY("DIFGLINK",$J,F,Y)=^UTILITY("DIFGLINK",$J)
 S Y="@"_^UTILITY("DIFGLINK",$J)
 Q

DIFGGSB2
DIFGGSB2 ;SFISC/DG,EDE(OHPRD)- ;6/19/92  9:28 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SPSPEC ; UNIQUE SPECIFIER
 F DIFGSB(DILL,"SPSPEC")=0:0 S DIFGSB(DILL,"SPSPEC")=$O(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"SPSPEC"))) Q:'DIFGSB(DILL,"SPSPEC")  I +^(DIFGSB(DILL,"SPSPEC")) Q:$P(^(DIFGSB(DILL,"SPSPEC")),U,2)'=""
 Q:'DIFGSB(DILL,"SPSPEC")
 I $P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"SPSPEC"),0),U,2)["P" S DIFGSB(DILL,"SPSPEC")=0 Q
 S $P(DIFGSB(DILL,"SPSPEC"),U,2)=$P(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"SPSPEC")),U,2)
 S DIFGSB(DILL,"FLD")=+DIFGSB(DILL,"SPSPEC")
 I '$D(DIFG(DILL,"MUL")) S DR=+DIFGSB(DILL,"SPSPEC")
 E  S DR(DIFG(DILL,"FILE"))=+DIFGSB(DILL,"SPSPEC")
 S DIFGSB(DILL,"SBT")="KEY:"
 D FIELDS^DIFGGSB1
 Q
 ;
PTRCHK ; CHECK FOR POINTER FIELD
 Q:$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P"
 S DITAB=DITAB+2
 S DILL=DILL+1
 D POINTER
 S DITAB=DITAB-2
 K DIFG(DILL)
 S DILL=DILL-1
 Q
 ;
POINTER ; POINTER FIELDS
 S DIFG(DILL,"FILE")=+$P($P(^DD(DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD"),0),U,2),"P",2),X=$P(^(0),U,4) S:$P(X,";")'=+X X=""""_$P(X,";")_""";"_$P(X,";",2)
 I $D(DIFGGU(DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE"),DIFGSB(DILL-1,"FLD"),"P")) S DIFG(DILL,"FE")=DIFGGU(DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE"),DIFGSB(DILL-1,"FLD"),"P")
 E  S DIFG(DILL,"FE")=$P(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_$P(X,";",1)_")"),U,$P(X,";",2))
 I '$D(^DIC(DIFG(DILL,"FILE"),0)) D KILLLL^DIFGGU Q
 S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL"),DIFG(DILL,"FNAME")=$P(^DIC(DIFG(DILL,"FILE"),0),U,1)
 I '$D(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)")) D KILLLL^DIFGGU Q
 I $D(Y),Y'="" S Z=Y,Y=""
 I $D(DIFGENV("LAYGO",DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD")))!($P(^DD(DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD"),0),U,2)'["'") S DIFG(DILL,"NOKEY")=""
 D START^DIFGGSB ; RECURSE
 Q

DIFGGU
DIFGGU ;SFISC/XAK,EDE(OHPRD)-FILEGRAM FUNCTIONS  ; [ 11/10/92  10:38 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; Required variables:
 ;
 ;   DILC
 ;   DITAB
 ;   DIFG("PARM")
 ;   DIFG("FGR")
 ;   DILL
 ;   DIFG(DILL,"FILE")
 ;   DIFG(DILL,"FNAME")
 ;   DIFG(DILL,"FE")
 ;   DIFG(DILL,"FGBL")
 ;   DIFG(DILL,"FUNC")
 ;
 Q  ; INVALID ENTRY POINT
 ;
LOOKUP ; EXTERNAL ENTRY POINT
 ; LOOKUP ENTRY IN FILE/SUBFILE
 D SETX
 Q:$D(DIFGGUQ)
 S Z=""
 I '$D(^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) D SETLINK
 I $D(^DD(DIFG(DILL,"FILE"),0,"UP")) S A=^("UP"),B=$O(^DD(A,"SB",DIFG(DILL,"FILE"),0)),C=$P(^DD(A,B,0),U,1),V=C_U_$S(DIFG("PARM")["N":B,1:"") K A,B,C
 E  S V=DIFG(DILL,"FNAME")_U_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"")
 S V=V_$S($D(DIFG(DILL,"NAV")):":",1:"")_U_DIFG(DILL,"FUNC")_"="_X
 I $D(DIFG(DILL,"NAV")),DIFG(DILL,"NAV")=1,$G(DIFG(DILL,"XREF"))?1A.E S V=V_U_DIFG(DILL,"XREF")_"=@"_^UTILITY("DIFGLINK",$J,DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE"))
 D INCSET
 D:Z'="" SPBLK
 K S,V,X,Z
 Q
 ;
SETLINK ;
 S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1),^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))=^UTILITY("DIFGLINK",$J)
 S Z="@"_^UTILITY("DIFGLINK",$J)
 Q
 ;
SETX ; SET X TO @LINK OR LOOKUP VALUE
 S X=""
 D SETX2
 Q:$D(DIFGGUQ)
 Q:X'=""
 I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01)) S X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01) Q
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 I '$D(DIFG(DILL,"MUL")) S DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE"),DR=".01"
 S DIQ(0)="N" D EN^DIQ1 K DIQ
 S X=^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01)
 K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
 I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
 Q
 ;
SETX2 ; IF POINTER AND ALREADY LOOKED UP SET @LINK
 K DIFGGUQ
 I $D(^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) S X="@"_^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))_"E"
 Q:$P(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P"
 S X=+$P($P(^DD(DIFG(DILL,"FILE"),.01,0),U,2),"P",2)
 I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01,"P")) S Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01,"P") I 1
 E  S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)"),U,1)
 NEW G
 S G="^"_$P(^DD(DIFG(DILL,"FILE"),.01,0),U,3)
 I '$D(@(G_Y_",0)")) S DIFGGUQ=1 Q
 S X=$S($D(^UTILITY("DIFGLINK",$J,X,Y)):"@"_^UTILITY("DIFGLINK",$J,X,Y),1:"")
 K Y
 Q
 ;
SPBLK ; SPECIAL BLOCK
 S DITAB=DITAB+2
 D ^DIFGGSB
 S DITAB=DITAB-2
 Q
 ;
INCSET ; EXTERNAL ENTRY POINT
 ; INCREMENT LINE COUNT AND SET LINE
 S DILC=DILC+1
 S S=""
 I '$D(DIFG("WP")) S:DITAB $P(S," ",DITAB)=" "
 S @(DIFG("FGR")_DILC_",0)")=S_V
 Q
 ;
KILLLL ; EXTERNAL ENTRY POINT
 ; KILL LAST LINE, DECREMENT LINE COUNT, KILL LAST LINK, DECREMENT LINK COUNT
 D KILLDEC,DELLINK
 Q
 ;
KILLDEC ; EXTERNAL ENTRY POINT
 ; KILL LAST LINE AND DECREMENT LINE COUNT
 K @(DIFG("FGR")_DILC_",0)")
 S DILC=DILC-1
 Q
 ;
DELLINK ; EXTERNAL ENTRY POINT
 ; DELETE LAST @LINK AND DECREMENT LINK COUNTER
 K ^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))
 S ^UTILITY("DIFGLINK",$J)=^UTILITY("DIFGLINK",$J)-1
 Q

DIFGO
DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;2/24/93  10:58 ;
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DIFG"","
 G OPT:$D(^DOPT("DIFG",6)) S ^(0)="FILEGRAM OPTION^1.01" K ^("B")
 F X=1:1:6 S ^DOPT("DIFG",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK
OPT ;
 S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
 ;
EN ;Entry point for all filegram options
 S DIC("S")="I Y>1.99" D:DI#2 ^DICRW G:Y<0 Q K DIC("S") ;ihs/ohprd/dg 8-21-91
 D @DI W !!
Q K %,DIC,DIK,DI,DA,I,J,X,Y Q
 ;
1 ;;CREATE/EDIT FILEGRAM TEMPLATE
 G EN^DIFGA
 ;
2 ;;DISPLAY FILEGRAM TEMPLATE
 S DIC("A")="Select FILEGRAM TEMPLATE: "
 S DIC="^DIPT(",DIC(0)="QEAM",DIC("S")="I $P(^(0),U,8)=1" D ^DIC I Y<0 K DIC Q
 W !! S DA=+Y,DIQ(0)="C" D EN^DIQ K DIC,DIQ G 2
 Q
 ;
3 ;;GENERATE FILEGRAM
 I '($D(IO)#2) D HOME^%ZIS
 I DUZ'>0 W $C(7),!!,"INVALID USER.  YOU CAN'T USE THIS OPTION." Q
 S DIC=+Y G ^DIFGG
 ;
 ;
4 ;;VIEW FILEGRAM
 W !! S DIC(0)="ZQEAMIN",DIC=1.12 D ^DIC Q:Y<0  S IOP="HOME" D ^%ZIS Q:POP
 S D0=+Y D EN1 G 4
EN1 S X=Y(0),Y=$P(X,U,6),Y=$S($D(^XMB(3.9,+Y,0))#2:$P(^(0),U),1:Y) W !!,Y
 S Y=$P(X,U,2) W !,$S(Y="s":"Sent",Y="i":"Installed",1:Y)
 W " on " S Y=$P(X,U) D DT W " by ",$P(X,U,3)
 S DIWL=1,DIWR=78,DIWF="WN" S D0=$P(X,U,6) S:'$D(^XMB(3.9,+D0,0)) D0=-1
 W !! S S=5,D=0 F  S (D,D1)=$O(^XMB(3.9,D0,2,D)) Q:D'>0  I $D(^(D,0))#2 S X=^(0) D ^DIWP Q:'$D(D)  S D=D1,S=S+1 I $E(IOST)="C",S+4>IOSL S DIR(0)="E" D ^DIR Q:'Y  S S=0
 S:D="" (D,D1)=-1 D 0^DIWW K DIP,Y,DIWF
 Q
DT I Y W $E(Y,6,7)," ",$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" ",Y\10000+1700 W:Y#1 " @ "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
 W Y Q
 ;
5 ;;SPECIFIERS
 S DI=+Y G 11^DIU
 ;
6 ;;INSTALL/VERIFY FILEGRAM
 S DIC(0)="QEAMNIZ",DIC=1.12 D ^DIC K DIC Q:Y<0  Q:'$P(Y(0),U,6)
 S DIFGLO="^XMB(3.9,"_$P(Y(0),U,6)_",2,",DIFGG=+Y
 D ^DIFG W !,$S($D(DIFGER):"UNSUCCESSFUL INSTALLATION: "_DIFGER,1:"DONE")
 S $P(^DIAR(1.12,DIFGG,0),U,2)=$S($D(DIFGER):"u",1:"i") K DIFGER,DIFGG Q

DIFGSRV
DIFGSRV ;SFISC/RWF-SERVER INTERFACE TO FILEGRAMS ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
HIST ;Add a message to the FileGram History file so it can be processed.
 S DIXM=0,U="^" X XMREC ;get first line
 I $P(XMRG,U)'="$DAT" S DIXM=DIXM+1,XQSTXT(DIXM)="First line of message doesn't start with '$DAT'"
 S DIFG=$P(XMRG,U,3)
 I DIFG<2 S DIXM=DIXM+1,XQSTXT(DIXM)="Can't update a VA FileMan file."
 I "^2^3^19^"[(U_DIFG_U) S DIXM=DIXM+1,XQSTXT(DIXM)="Update to a protected file (#"_DIFG_")."
 Q:DIXM
 S DIFG("FE")=+$P(XQSUB,"#",2),DIFG("TEMPLATE")="",DIFG("DUZ")=XMFROM
 D LOG^DIFGG
 Q

DIFROM
DIFROM ;SFISC/XAK-GENERATE INITS ;02:57 PM  7 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D Q
 S X=$S('$D(^DD("VERSION"))#2:0,1:^("VERSION")),Y=$P($T(DIFROM+1),";",3) G:X'=Y ERV K X,Y
 I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
 D WARN
 S DIR("A")="Enter the Name of the Package (2-4 characters)"
 S DIR(0)="FO^2:4:0^I X'?1U1.NU K X"
 S DIR("?")="^D R^DIFROMH",DIR("??")=DIR("?")
 D ^DIR G Q:$D(DIRUT) K DIR
 S DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC K D,DIC S DPK=+Y,DPK(0)=$S($D(Y(0)):Y(0),1:"")
R W !!,"I am going to create a routine called '",X,"INIT'."
 S DTL=X,X=X_"INIT" D OS^DII
 I $D(^DD("OS",DISYS,18)) X ^(18) I  W $C(7),!,"but '"_X_"' is ALREADY ON FILE!" S Q=1
 K DIR S DIR("A")="Is that OK",DIR(0)="Y",DIR("??")="^D R1^DIFROMH"
 D ^DIR G Q:$D(DIRUT)!'Y
 S DIR("A")="Would you like to include Data Dictionaries",DIR("B")="YES"
 S DIR("??")="^D R3^DIFROMH" D ^DIR G Q:$D(DIRUT) I 'Y S F(-1)=0 G DD
 G L:DPK<0 S DIR("A")="Would you like to see the package definition"
 S DIR("??")="^D CUR^DIFROMH1",DIR("B")="NO" D ^DIR G Q:$D(DIRUT)
 I Y D L^DIFROMH1
 S DIR("A")="Do you want to accept the current definition"
 S DIR(0)="Y",DIR("??")="^D PKG^DIFROMH1" D ^DIR G Q:$D(DIRUT) S DIH=Y
 F DA=0:0 S DA=$O(^DIC(9.4,DPK,4,DA)) G:'$D(^(+DA,0)) DD:$D(F),L S Y=+^(0) I $D(^DIC(Y,0))#2 S F(Y)=$P(^(0),U) W !!,F(Y) D SF G Q:%<0
L W !!,"THEN PLEASE LIST THE FILES THAT YOU WISH TO TRANSPORT:" S DIH=0,DPK=-1
 F F=1:1 G Q:$D(DTOUT) K DIC S DIC("S")="I Y>1.9999&'$D(F(+Y))",DIC(0)="AIQEZ",DIC="^DIC(" D ^DIC G:Y<0 Q:X[U,DD S F(+Y)=$P(Y,U,2) D F
DD W ! F Y=1,2,3,4 S D=$P("DIE^DIPT^DIBT^DIST",U,Y),DIC=$P("INPUT^PRINT^SORT^FORM(S):",U,Y)_$S(Y<4:" TEMPLATE(S):",1:"") F %=0:0 S %=$O(^DIC(9.4,DPK,D,%)) Q:'$D(^(+%,0))  S DH=$P(^(0),U),X=$P(^(0),U,2) D T
 S DN=DTL_$E("INI",1,5-$L(DTL))
 K ^UTILITY(U,$J),DR S DRN=0,F=0,Q=DPK G Q:$D(F)+$D(Q)=2
 D VER^DIFROM12 G Q:$D(DIRUT)
S G ^DIFROM0
 ;
T W !,DIC,?24,DH
 I Y'=4 F F=0:0 S @("F=$O(^"_D_"(""B"",DH,F))"),DIC="" Q:'F  I @("$D(^"_D_"(F,0))"),$P(^(0),U,4)=X!'X S Q(D,F)="",DIFC=1 G TQ
 I Y=4 F F=0:0 S F=$O(^DIST(.403,"B",DH,F)),DIC="" Q:'F  I $D(^DIST(.403,F,0)),$P(^(0),U,8)=X S Q(D,F)="",DIFC=1 G TQ
 W $C(7)," **NOT FOUND** "
TQ Q
 ;
SF G F:$O(^DIC(9.4,DPK,4,DA,1,0))'>0
 F %=0:0 S %=$O(^DIC(9.4,DPK,4,DA,1,%)) Q:%'>0  I $D(^(%,0)) S E=$P(^(0),U),D=$O(^DD(+Y,"B",E,0)) D:D="" ERF I $D(^DD(+Y,D,0)) S F(+Y,+Y,D)="",%C=+$P(^(0),U,2) I %C W "  (",E,")" S F(+Y,%C)=0
 S F(+Y,+Y)=1,E=+Y S:(+Y'=200)!(DTL="XU") F(+Y,+Y,.01)=0 G E
F S F(+Y,+Y)=0,%=1,E=0 K %A
E F E=E:0 S E=$O(F(+Y,E)) Q:E'>0  F D=0:0 S D=$O(^DD(E,"SB",D)) Q:D'>0  I Y-E!'$D(%A)!$D(%A(D)) S F(+Y,D)="" S:$D(%A) %A(D)=0
 S F(+Y,0)=^DIC(+Y,0,"GL"),D=$P(@(F(+Y,0)_"0)"),U,4),DPK(1)=+Y S:D<2 D=""
 S DA(1)=DPK,DR="222.1;222.2;223;222.4;222.7;S:""n""[X Y=0;222.8;222.9;"
 S DIE=$S(DPK>0:"^DIC(9.4,",1:"^UTILITY($J,")_DA(1)_",4,"
 I DPK<0 S ^UTILITY($J,-1,4,0)="^9.44",^(+Y,0)=+Y,DA=+Y
 I 'DIH W ! S DIE("W")="W !?2,$P(DQ(DQ),U),?32,"": """ D ^DIE I $D(Y) S %=-1
 S F(DPK(1),-222)=$S($D(@(DIE_"DA,222)")):^(222),1:"y"),F(DPK(1),-223)=$S($D(^(223)):^(223),1:"") K DIE,DR
 Q
 ;
ERF S D=-1 W $C(7),!,"  INVALID FIELD LABEL:  "_E,! Q
ERV W $C(7),!!,"Your FileMan Version number: "_X_"  does not match the version number",!,"on the DIFROM routine: "_Y_" !!",!!,"You must run ^DINIT before you can build an INIT!!",! K X,Y Q
Q G Q^DIFROM11
WARN N I F I=1:1 Q:$T(WARN+I)=""  W !,$P($T(WARN+I),";;",2)
 ;;                    * * Please Note * *
 ;;
 ;;     DIFROM gererates routines in the following format:
 ;;
 ;;     nmspInxx
 ;;     ^^^^^^^^
 ;;     ||||||||
 ;;     |||||| \\- xx is any combination of numbers and
 ;;     ||||||     upper case alpha characters.
 ;;     ||||||
 ;;     ||||| \--- n is a number 0 - 9 and uppercase letter N.
 ;;     |||||
 ;;     |||| \---- I is always uppercase letter I.
 ;;     ||||
 ;;      \\\\----- 2 to 4 characters of package namespace.
 ;;
 ;;     Any routines that support the init process should not
 ;;     be in this format.
 ;;

DIFROM0
DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ;02:07 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %=2,DIT=0,DIH=""
 I DPK<0,$O(F(0))>0 K DIR S DIR(0)="Y",DIR("A")="Do you want to include all the templates and forms",DIR("B")="NO",DIR("??")="^D NOPKG^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIT=Y=1
 W ! S DIR(0)="YA",DIR("??")="^D ^DIFROMH",DIR("B")="YES"
 ;NOTE: I removed 9.8 (ROUTINE FILE) from this list for V19 but none of the supporting code. (tkw)
 F DL=19,3.6,19.1,.5,9.2 I $D(^DIC(DL,0)) S X=$P(^(0),U),DIR("A")="Would you like to include "_X_"S?"_$E("       ",1,13-$L(X)) D ^DIR G Q:$D(DIRUT) I Y=1 S DL(DL)=DL,DIFC=1
 G:$D(F(-1))&('$D(DIFC)) Q
S W ! S DIR("A")="Would you like security codes sent along: ",DIR("B")="NO"
 S DIR("??")="^D S^DIFROMH" D ^DIR G Q:$D(DIRUT) S DSEC=Y=1 K ^UTILITY("DI",$J)
M ;
 S DIR("A")="Maximum Routine Size    (2000 - 9999) : ",DIR("B")=^DD("ROU"),DIR(0)="NA^2000:9999"
 S DIR("??")="^D M^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIFRM=Y
GO W ! D WAIT^DICD
 D:DPK>0 PKG^DIFROM12
 D  I DTL="DI" S DTL="DD" D  S DTL="DI"
 .F Y=19,3.6,19.1,.5,9.8,9.2 I $D(DL(Y)) S X=$S(Y=19:"OPT",Y=3.6:"BUL",Y=19.1:"SE",Y=.5:"FUN",Y=9.8:"ROU",Y=9.2:"HEL") D ADD,A:'Y
 D SBF
 K DL,DIR S DL=DRN,DRN=1 G ^DIFROM1
ADD ;
 S DH=$S(DTL="XU":"DD",1:DTL)
 Q:$D(^DIC(Y,0))[0!$D(DTL(Y))  Q:$P(^(0),X,1)]""!'$D(^(0,"GL"))
 S Y=^("GL"),X=$S(X="ROU":"RTN",X="SE":"KEY",1:X)
 Q
A F D=0:0 S D=$O(^DIC(9.4,DPK,"EX",D)) Q:D'>0  I $P(DH,$P(^(D,0),U))="" G DH
 S D=$O(@(Y_"""B"",DH,0)")),%X=Y_"D,",%Y="^UTILITY(U,$J,X,D,"
 G DH:D'>0,DH:D<100&(X="FUN") S Q(X)=0
 D %XY^%RCR G H:X'="OPT"
 S %=^UTILITY(U,$J,X,D,0),%1=+$P(%,U,12),%1=$S($D(^DIC(9.4,%1,0)):$P(^(0),U),1:""),$P(%,U,12)=%1,$P(%,U,5)=""
 S %1=+$P(%,U,7),%1=$S($D(^DIC(9.2,%1,0)):$P(^(0),U),1:""),$P(%,U,7)=%1,^UTILITY(U,$J,X,D,0)=% K ^(3.96),^(10,"B"),^("C")
 I $D(^UTILITY(U,$J,X,D,220)) S %=^(220),%1=$S($D(^XMB(3.6,+%,0)):$P(^(0),U),1:""),$P(%,U)=%1,%1=$S($D(^XMB(3.8,+$P(%,U,3),0)):$P(^(0),U),1:""),$P(%,U,3)=%1,^UTILITY(U,$J,X,D,220)=%
 F %=0:0 S %=$O(^DIC(19,D,10,%)) Q:%'>0  I $D(^(%,0)),$D(^DIC(19,+^(0),0)) S ^UTILITY(U,$J,X,D,10,%,U)=$P(^(0),U)
H K:"BULKEY"[X ^UTILITY(U,$J,X,D,2) G:X'="HEL" DH
 K ^UTILITY(U,$J,X,D,4) S $P(^(0),U,4)="" K ^(2,"B"),^UTILITY(U,$J,X,D,10,"B")
 F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,10,%2)) Q:'%2  I $D(^(%2,0))#2 S %1=+^(0),%1=$S($D(^MAG(%1,0)):$P(^(0),U,1),1:"") K:%1="" ^UTILITY(U,$J,X,D,10,%2) I %1]"" S $P(^UTILITY(U,$J,X,D,10,%2,0),U,1)=%1
 F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,2,%2)) G DH:%2'>0 I $D(^(%2,0))#2,$P(^(0),U,2) S %1=^(0),%=1 D HP1 Q:%<0
 K %1,%2 Q
HP1 I $D(^DIC(9.2,+$P(%1,U,2),0)) S ^UTILITY(U,$J,X,D,2,%2,0)=$P(%1,U)_U_$P(^(0),U) Q
 W !,$C(7),"The Help Frame, "_$P(^DIC(9.2,D,0),U)_" has the keyword "_$P(%1,U)
 W !,"whose Related Frame does not exist.  Shall I exclude it" D YN^DICN
 K:%=1 ^UTILITY(U,$J,X,D,2,%2) Q
 ;
DH S DH=$O(@(Y_"""B"",DH)")) G A:DH]""&(DTL="XU"!($P(DH,DTL,1)="")) Q
 ;
ERM W $C(7),!!?5,"Was not able to get a message number for the network INIT",!?10,"DIFROM ABORTED!!",! Q
 ;
Q G Q^DIFROM11
SBF N I,II
 S I=0 F  S I=$O(F(I)) Q:I'>0  S II=0 F  S II=$O(F(I,II)) Q:II'>0  S ^UTILITY("^",$J,"SBF",I,II)=""
 Q

DIFROM1
DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ;02:23 PM  28 Nov 1994 [ 02/22/96  3:20 PM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
L S DH=" F I=1:2 S X=$T(Q+I) Q:X=""""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y",F=$O(F(F))  ;IHS/MFD changed 5,99 to 5,999
 I F'>0 D:DSEC SEC K ^UTILITY("DI",$J) G ^DIFROM11
 S ^UTILITY($J,DL+1,0)="^DIC("_F_",0,""GL"")",^UTILITY($J,DL+2,0)="="_F(F,0),^UTILITY($J,DL+3,0)="^DIC(""B"","""_F(F)_""","_F_")",^UTILITY($J,DL+4,0)="=",DL=DL+4
 S DH=" Q:'DIFQ("_F_") "_DH
 F E="%","%D" S %X="^DIC("_F_","""_E_""",",E=0 D %XY
 I DSEC S E="" F DSEC=DSEC:1 S E=$O(^DIC(F,0,E)) Q:E=""  I E'="GL" S ^UTILITY("DI",$J,DSEC,0)="^DIC("_F_",0,"""_E_""")" S DSEC=DSEC+1 S ^UTILITY("DI",$J,DSEC,0)="="_^DIC(F,0,E)
 F D=0:0 S D=$O(F(F,D)),E=0,%X="^DD("_D_",0" Q:D'>0  S ^UTILITY($J,DL+1,0)=%X_")",DL=DL+2,^UTILITY($J,DL,0)="="_^DD(D,0),%X=%X_"," D V F X=0:0 S X=$O(^DD(D,X)) Q:X'>0  S %X="^DD("_D_","_X_",",E="%Z#2" D SAVE:$D(F(F,D))<9!$D(F(F,D,X))
 D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 I $P(F(F,-222),U,7)'="y" G L
 S DL=DL+1,E="%Z#2=0",%X=F(F,0),@("D="_%X_"0)")
 S ^UTILITY($J,DL+1,0)="^UTILITY(U,$J,"_F_")",^UTILITY($J,DL+2,0)="="_%X,^UTILITY($J,DL+3,0)="^UTILITY(U,$J,"_F_",0)",^UTILITY($J,DL+4,0)="="_D,%Y="^UTILITY(U,$J,"_F_",",%Z=0,%C(-1)=0,%B=0,%A="",DL=DL+5
 D N S DH=$P(DH,"DIFQ")_"DIFQR"_$P(DH,"DIFQ",2,99)
 D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 G L
 ;
SAVE K DSV I $D(^(X,8)) S DSV(8)=^(8) K ^(8)
 F %Z=8.5,9 I $D(^(%Z)),^(%Z)'=U,'($P(^(0),U,2)["K"&(^(%Z)="@")) S DSV(%Z)=^(%Z) K ^(%Z)
 D %XY
 F %Z=8,8.5,9 I $D(DSV(%Z)),DSV(%Z)]"" S ^DD(D,X,%Z)=DSV(%Z) I DSEC S ^UTILITY("DI",$J,DSEC,0)="^DD("_D_","_X_","_%Z_")",DSEC=DSEC+1,^UTILITY("DI",$J,DSEC,0)="="_DSV(%Z),DSEC=DSEC+1
 Q
 ;
SEC S DH=" I DSEC"_DH,%X="^UTILITY(""DI"",$J,",%Y="^UTILITY($J," D %XY^%RCR
 D FILE^DIFROM3:$O(^UTILITY($J,0))>0 G:'$D(DRN) EQ^DIFROM11 S DH=$E(DH,8,999) Q
 ;
%XY ;
 W "." S %Z=0,%A="",%C(-1)=0,%Y=%X
S S %B=""
N S @("%B=$O("_%X_%A_"%B))"),%C(%Z)=%C(%Z-1) I '%B,%B'?1"0".E,@E S %B=""
 I %B["," F %C=0:0 S %C=$F(%B,",",%C) Q:'%C  S %C(%Z)=%C(%Z)+1
 I %B="" G Q:'%Z S @("%B="_$P(%A,",",%Z+%C(%Z-2),%Z+%C(%Z-1))),%Z=%Z-1,%A=$P(%A,",",1,%Z+%C(%Z-1))_$E(",",%Z>0) G N
 I @("$D("_%X_%A_"%B))#2=1") S %V=^(%B) D W:%V'?.ANP S %=$P("""",U,+%B'=%B),%=%Y_%A_%_%B_%_")" D B:$L(%V)>240 S DL=DL+1,^UTILITY($J,DL,0)=%,DL=DL+1,^UTILITY($J,DL,0)="="_%V
 I @("$D("_%X_%A_"%B))<9") G N
 G D:+%B=%B F %C=0:0 S %C=$F(%B,"""",%C) Q:'%C  S %B=$E(%B,1,%C-1)_""""_$E(%B,%C,999),%C=%C+1
 S %B=""""_%B_""""
D S %A=%A_%B_",",%Z=%Z+1 G S
 ;
B I $L(%V)>255 W !,"WARNING--DATA TOO LONG:  " D X
 S DL=DL+1,^UTILITY($J,DL,0)=%,%=$C(126)_$E(%V,1,160),%V=$E(%V,161,999) Q
 ;
W W !,"WARNING--CONTROL CHARACTER IN DATA:  "
X W $C(7),%X,%A,%B,")--",!?3,%V
Q Q
V K DSV I $D(^DD(D,0,"VR"))#2 S DSV=^("VR") K ^("VR")
 D %XY
 I $D(DSV)#2 S ^DD(D,0,"VR")=DSV K DSV
 Q

DIFROM11
DIFROM11 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;APR 13, 1995@14:31;11/24/92  10:31
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %Y="^UTILITY(U,$J,D,Y,",E=0
 F D="DIE","DIPT","DIBT" S %X=U_D_"(Y,",Y=0 F  S @("Y=$O(^"_D_"(Y))") Q:'Y  I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,4) I F,$P(DSV,U,8)<3,$D(F(F))!$D(Q(D,Y)) D 1
 S D="DIST(.403,",%X=U_D_"Y,",Y=0 F  S Y=$O(^DIST(.403,Y)) Q:'Y  I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,8) I F,$D(F(F))!$D(Q("DIST",Y)) D 1
 S X="" F D=0:0 S X=$O(^UTILITY(U,$J,X)) Q:X=""  S %X="^UTILITY(U,$J,"_""""_X_"""," D %XY^DIFROM1
 K ^UTILITY(U,$J) D FILE^DIFROM3:DL K ^UTILITY($J) G:'$D(DRN) EQ
 D DIFROM2 G Q
1 ;
 I 'DIT F %=0:0 S %=$O(^DIC(9.4,DPK,"EX",%)) Q:%'>0  I $P($P(DSV,U),$P(^(%,0),U))="" G QQ
 I D["DIST" I DIT!($P($P(DSV,U),DTL)="")!$D(Q("DIST",Y)) S Q("DIST")=0 D %XY^%RCR S $P(DSV,U,4)="",$P(DSV,U,6)="" S:'DSEC $P(DSV,U,2,3)=U S ^UTILITY(U,$J,D,Y,0)=DSV D BLK G QQ
 I DIT!($P($P(DSV,U),DTL)="")!$D(Q(D,Y)) S Q(D)=0 D %XY^%RCR K ^UTILITY(U,$J,D,Y,"RD"),^("AB") K:'$D(DTL(F))&(D["DIBT") ^(1) S:'DSEC ^(0)=$P(DSV,U,1,2)_U_U_F_U_U_U_U_$P(DSV,U,8,9) W "."
QQ Q
BLK N D,%X S D="DIST(.404,",%X=U_D_"Y,"
 F I=0:0 S I=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I)) Q:'I  I $D(^(I,0)) S %=+$P(^(0),U,2) S:$D(^DIST(.404,%,0)) $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,0),U,2)=$P(^(0),U) S K=Y,Y=% D:$D(^DIST(.404,%,0)) %XY^%RCR S Y=K D B2
 Q
B2 F J=0:0 S J=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J)) Q:'J  I $D(^(J,0)) S %=+^(0) I $D(^DIST(.404,%,0)) S $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J,0),U)=$P(^(0),U),K=Y,Y=% D %XY^%RCR S Y=K
 Q
 ;
DIFROM2 ;
 S DIFROM=5,Y=DRN-1,S=""
 S DH=" ; LOADS AND INDEXES DD'S",^UTILITY($J,.3,0)=" K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U=""^"",DSEC=1"
 S X="",DD="A" F E=1:1 S DD=$O(Q(DD)) Q:DD=""  S X=X_","""_$E(DD,1,3)_""""
 S DL=0,^UTILITY($J,1.4,0)=" S NO=$P(""I 0^I $D(@X)#2,X[U"",U,%) I %<1 K DIFQ Q"
 S DIRS(1)=" I %<1 K DIFQ Q"
 S:E>1 ^UTILITY($J,2,0)=" F X="_$E(X,2,99)_" D W Q:'$D(DIFQ)"
 G ^DIFROM2
 ;
EQ W $C(7),!!,"PACKAGE TOO LARGE!  DIFROM CAN NOT BUILD ANY MORE INIT ROUTINES.",!!
Q K ^UTILITY($J),^("^",$J),^UTILITY("DIF",$J),DIFROM,DR,DD,DLAYGO,DIRS,DIMA,DWLW,DREF,D1
 K DI,DISYS,DIX,DIY,DO,DZ,DIK,DIDUZ,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW
 K %,%1,%2,%A,%B,%C,%DT,%V,%X,%Y,%Z,DDH,DG,D0,DA,DIFRM,DL,D,E,DIC,DIE,DN,DPK,DQ
 K DIFC,DRN,DIRUT,DIROUT,DTOUT,DUOUT,DIR,DIFQR,DNAME,DSEC,DTL
 K A,C,I,J,K,F,L,N,Q,R,S,X,Y,Z,DSV,DIDIU,DIFKEP,DIFR,DIFR1,DIFR2,DIT,DH,DILN2,DIFL,VERSION
 K DIFRDIFI,DIFRF,DIFRIR,DIFRRMAX,DIFRRN,DIFRRTN,DIFRRXT,DIFRS,DIFRTX
 K DIOVRD
 Q

DIFROM12
DIFROM12 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;6/20/91  11:54 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
VER ;
 W !!?5,"Now you must enter the information that goes on the second line",!?5,"of the INIT routines.",!
 G:DPK<1 V2
 S DIE=9.4,DA=Q,DR=22,DR(2,9.49)=1 D ^DIE I $D(Y) S (DUOUT,DIRUT)=1 Q
 G V2:'$D(D1) S X=^DIC(9.4,DPK,22,D1,0),DPK(1)=$P(X,U,1),DILN2=" ;;"_DPK(1)_";"_$P(^DIC(9.4,DPK,0),U,1)_";;",Y=$P(X,U,2) D DD^%DT S DILN2=DILN2_Y
 W !! Q
V2 K DIR S DIR(0)="F^4:30",DIR("A")="Package Name",DIR("?")="^D PNM^DIFROMH1" D ^DIR Q:$D(DIRUT)  S DILN2=Y
 K DIR S DIR(0)="F^1:9^K:'(X?1.3N.1""."".2N.1A.2N) X",DIR("A")="Version",DIR("?")="^D VER^DIFROMH1" D ^DIR Q:$D(DIRUT)  S DPK(1)=Y,DILN2=" ;;"_Y_";"_DILN2_";;"
 K DIR S DIR(0)="D^::EX",DIR("A")="Date Distributed",DIR("?")="^D VDT^DIFROMH1" D ^DIR Q:$D(DIRUT)  D DD^%DT S DILN2=DILN2_Y
 W !! Q
PKG ;
 S %Y="^UTILITY(U,$J,""PKG"",DPK,",%X="^DIC(9.4,"_DPK_","
 W !,"Moving "_$P(^DIC(9.4,DPK,0),U)_" Entry into Init's."
 S D=%X_"""22""," D %XY^%RCR K DR S:$D(^DISV(DUZ,D)) DR=^(D)
 I $P(^DIC(9.4,DPK,0),U,4) S DL=$S($D(^DIC(9.2,+$P(^(0),U,4),0))#2:$P(^(0),U),1:""),$P(^UTILITY(U,$J,"PKG",DPK,0),U,4)=DL
 F %="PRE","INI","INIT" S:$D(^UTILITY(U,$J,"PKG",DPK,%)) $P(^(%),U,2)=""
 K ^UTILITY(U,$J,"PKG",DPK,"VERSION"),DIE Q:'$D(^ORD(100.99,1,5,DPK,0))
OR ;
 S %X="^ORD(100.99,1,5,DPK,",%Y="^UTILITY(U,$J,""OR"",DPK," D %XY^%RCR
 S %=$P(^ORD(100.99,1,5,DPK,0),U,4)
 I %]"" S %=$S($D(^ORD(100.98,%,0)):$P(^(0),U),1:"") I %]"" S $P(^UTILITY(U,$J,"OR",DPK,0),U,4)=%
 F I=0:0 S I=$O(^ORD(100.99,1,5,DPK,1,I)) Q:'I  I $D(^(I,0)) S %=+$P(^(0),U) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,1,I,0),U)=$P(^(0),U) D OR1
 F I=0:0 S I=$O(^ORD(100.99,1,5,DPK,5,I)) Q:'I  I $D(^(I,0)) S %=+$P(^(0),U,3) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,5,I,0),U,3)=$P(^(0),U)
 K ^UTILITY(U,$J,"OR",DPK,"B")
 Q
OR1 F J=0:0 S J=$O(^ORD(100.99,1,5,DPK,1,I,1,J)) Q:'J  I $D(^(J,0)) S %=+$P(^(0),U) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,1,I,1,J,0),U)=$P(^(0),U)
 Q

DIFROM2
DIFROM2 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT1' ;02:38 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S ^UTILITY($J,2.5,0)=" Q:'$D(DIFQ)  S %=2 W !!,""ARE YOU SURE EVERYTHING'S OK"" D YN^DICN I %-1 K DIFQ Q"
 I $D(^DIC(9.4,DPK,"INI")),$P(^("INI"),U)]"" S ^UTILITY($J,2.6,0)=" D ^"_$P(^("INI"),U)_" D NOW^%DTC S DIFROM(""INI"")=%"
 S ^UTILITY($J,2.7,0)=" I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2"
 S ^UTILITY($J,3,0)=" D DT^DICRW K ^UTILITY(U,$J),^UTILITY(""DIK"",$J) D WAIT^DICD" K Q
 S ^UTILITY($J,3.1,0)=" S DN=""^"_DN_""" F R=1:1:"_Y_" D @(DN_$$B36(R)) W ""."""
 S X=4,Q=" ;",^UTILITY($J,X,0)=" F  S D=$O(^UTILITY(U,$J,""SBF"","""")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"""")) I D>0  K ^(D) D IX"
 S DIRS=" K:%<0 DIFQ"
 S E=$E(DTL_"INIT",1,7),DNAME=E_1,D=-9999 F DD=1:1 S X=$E($T(TEXT+DD),4,999) Q:X=""  S ^UTILITY($J,DD+4,0)=X S:DD=7 ^UTILITY($J,DD+4,0)=X_DIRS
 S ^UTILITY($J,1.5,0)="ASK I %=1,$D(DIFQ(0)) W !,""SHALL I WRITE OVER FILE SECURITY CODES"" S %=2 D YN^DICN S DSEC=%=1"_DIRS(1)
 D ZI^DIFROM3 G ^DIFROM3
 Q
TEXT ;
 ;;DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 ;; I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 ;; K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;; ;
 ;;W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 ;; S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 ;; S:%=2 DIFQ(X)=0
 ;; Q
 ;; ;
 ;;OPT ;OPTION
 ;;RTN ;ROUTINE DOCUMENTATION NOTE
 ;;FUN ;FUNCTION
 ;;BUL ;BULLETIN
 ;;KEY ;SECURITY KEY
 ;;HEL ;HELP FRAME
 ;;DIP ;PRINT TEMPLATE
 ;;DIE ;INPUT TEMPLATE
 ;;DIB ;SORT TEMPLATE
 ;;DIS ;FORM
 ;; ;
 ;;SBF ;FILE AND SUB FILE NUMBERS
 ;;IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 ;; S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 ;; I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 ;; Q
 ;;B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
 ;;N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)

DIFROM3
DIFROM3 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT2' (HELP FRAMES) ;02:44 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIRS=" S DIFQ=1"
 S DNAME=E_2,DL=0,(DH,Q)=" ;" K ^UTILITY($J) F DD=1:1 S X=$T(TEXT+DD) Q:X=""  S ^UTILITY($J,DD,0)=$E(X,4,999) S:$E(X,4)="U" ^(0)=^(0)_DIRS
 S DIFROM=2 D ZI G ^DIFROM4
 ;
FILE ;
 D:'$D(DISYS) OS^DII S DL=0,Q="Q Q",S=" ;;"
NAME S D=$L(DH)+10
 I DRN>12959 K DRN Q
 S DNAME=DN_$$B36(DRN)
ZI ;
 I '$D(DIFROM(1)) S %H=+$H D YX^%DTC S DIFROM(1)=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)
2 K ^UTILITY($J,0) S ^(0,1)=DNAME_" ; ; "_DIFROM(1),^(1.1)=DILN2
 S ^UTILITY($J,0,2)=DH,^UTILITY($J,0,3)=Q F L=4:1 S DL=$O(^UTILITY($J,DL)) Q:DL'>0  S ^UTILITY($J,0,L)=S_^(DL,0),D=$L(^(L))+D I D+380>DIFRM,$E(^(L),4)'="^",$E(^(L),4)'=$C(126) Q
 S DRN=DRN+1,X=DNAME X ^DD("OS",DISYS,"ZS") W !,X_" HAS BEEN FILED..." G NAME:DL>0
K K %A,%B,%C,%Z,^UTILITY($J) S DL=0 Q
 ;
B36(X) ;Calculate base 36 number from 0 (000) to 46,655 (ZZZ).
 S X=$G(X) I X>46655 Q ""
 Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)
 ;
TEXT ;
 ;; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 ;; I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 ;; Q
 ;; ;
 ;;ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 ;; S DIK=DIC
 ;;HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R=""  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 ;; F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 ;; S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 ;; I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
 ;;IX D IX1^DIK G HELP
 ;; ;
 ;;U I $D(DIRUT)
 ;; W ! Q
 ;;REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 ;; S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 ;; I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 ;; S DIR("A")="Shall I replace your file with mine"
 ;; S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 ;; S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 ;; S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 ;; S:'Y DIU(0)=DIU(0)_"D"
 ;; S DIR("A")="Do you want to keep the Templates"
 ;; S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 ;; S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

DIFROM4
DIFROM4 ;SFISC/XAK-CREATES 'INIT3' ;10:40 AM  11 Feb 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DNAME=E_3,DIRS=E_4,DL=0,(DH,Q)=" ;"
 K ^UTILITY($J) F DD=1:1 S X=$T(TXT+DD) Q:X=""  S ^UTILITY($J,DD,0)=$E(X,4,999) S:$E(X,4,5)="OR" ^(0)=^(0)_DIRS
 D ^DIFROM41
 S DIFROM=2 D ZI^DIFROM3 G ^DIFROM42
TXT ;
 ;; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 ;; S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X=""  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 ;; I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 ;; G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 ;; I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
 ;;OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^
 ;;NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 ;; I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 ;; I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 ;; S DIC=.5,DLAYGO=0,N="FUN" D ADD
 ;; S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 ;; K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 ;; S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 ;; K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 ;; K ^UTILITY("DIFROM",$J) Q

DIFROM41
DIFROM41 ;SFISC/XAK-CREATES 'INIT3' (CONT.) ;11:02 AM  13 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S L=0 F DD=DD:1 S L=L+1,X=$T(TXT+L) Q:X=""  S ^UTILITY($J,DD,0)=$E(X,4,999)
 Q
TXT ;
 ;;DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 ;; E  S DISYS=^DD("OS")
 ;; Q:'$D(^DD("OS",DISYS,"ZS"))
 ;; S DIFR1=""
 ;;DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 ;; F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 ;; G DZ1
 ;; ;
 ;;OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 ;; W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 ;; I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 ;; S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 ;; S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 ;; D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 ;; F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 ;; S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;; ;
 ;;ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
 ;;Q Q
 ;;A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 ;; K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 ;; I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 ;; I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D
 ;; .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
 ;; .Q
 ;; I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 ;; I N="DIST(.403," D BLK
 ;; S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 ;; D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 ;; I N="DIST(.403," D
 ;; .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA)
 ;; .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q
 ;; .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled"
 ;; .Q
 ;; Q
 ;;BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 ;; K A0,A1,A2,J,L Q
 ;;B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D
 ;; .N X S X=0
 ;; .F  S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X)
 ;; .Q
 ;; S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 ;; F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D
 ;; .N X S X=0
 ;; .F  S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X)
 ;; .Q
 ;; S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 ;; Q
 ;;KAD(D0) N D1,X
 ;; S X=0 F  S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0  S D1=0 F  S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0  K ^DIC(19,"AD",X,D0,D1)
 ;; Q

DIFROM42
DIFROM42 ;SFISC/XAK-CREATES 'INIT4' ;10:55 AM  11 Feb 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DNAME=E_4,DL=0,(DH,Q)=" ;"
 K ^UTILITY($J) F DD=1:1 S X=$T(TXT+DD) Q:X=""  S ^UTILITY($J,DD,0)=$E(X,4,999)
 S DIFROM=2 D ZI^DIFROM3 G ^DIFROM5
TXT ;
 ;;EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 ;; S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 ;; S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 ;; D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 ;; I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 ;; D OR
 ;; S DA(1)=1 D IX1^DIK
 ;; Q
 ;;OR S (N,I)=0,X=""
 ;; F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 ;; S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 ;; F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 ;; S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 ;; Q
 ;;OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 ;; S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 ;; Q
 ;;ADDP N I,J,N,R,DA,DLAYGO S %=""
 ;; S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

DIFROM5
DIFROM5 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT' ;03:14 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIFRF=0,DIFRRXT="567890ABCDEFGHIJKLMNOPQRUVWXZ",DIFRRN=E,DIFRTX=0
 S DIFRRMAX=$S($G(DIFRM)>1999:DIFRM,$G(^DD("ROU"))>1999:^("ROU"),1:2000)
 F DIFRIR=1:1 S X=0,Q=" Q",DNAME=DIFRRN_$E(DIFRRXT,DIFRIR) D  Q:DIFRF'>0
 .S DIFRS=510
 .F  S DIFRF=$O(F(DIFRF)) Q:DIFRF'>0  D  Q:DIFRS>DIFRRMAX
 ..S X=X+1
 ..S DH=$P(@(F(DIFRF,0)_"0)"),U,2)
 ..S ^UTILITY($J,X,0)=" ;;"_DH_";"_F(DIFRF)_";"_F(DIFRF,0)_";"_$S($D(F(DIFRF,DIFRF)):F(DIFRF,DIFRF),1:"")_";"_$TR(F(DIFRF,-222),"^",";"),DIFRS=DIFRS+$L(^UTILITY($J,X,0))
 ..S X=X+1
 ..S ^UTILITY($J,X,0)=" ;;"_F(DIFRF,-223),DIFRS=DIFRS+$L(^UTILITY($J,X,0))
 ..Q
 .S DH=$S(DIFRIR=1:" K ^UTILITY(""DIF"",$J) S DIFRDIFI=1",1:"")
 .S DH=DH_" F I=1:1:"_X_" S ^UTILITY(""DIF"",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1"
 .S ^UTILITY($J,.5,0)="IXF ;;"_$P(DPK(0),U,1,2)
 .S DIFRTX=DIFRTX+X,D=-9999,DIFROM=X D ZI^DIFROM3 K ^UTILITY($J)
 .Q
 S Q=$S('$D(^DIC(9.4,DPK,"INIT")):1,$P(^("INIT"),U)?1PA.E:$P(^("INIT"),U),1:1)
 S DRN=^DD("VERSION"),X=DIFROM
 S ^UTILITY($J,5,0)=" F DIF=1:2:"_DIFRTX_" S %=^UTILITY(""DIF"",$J,DIF),DIK=$P(%,"";"",5),N=$P(%,"";"",3),D=$P(%,"";"",4)_U_N D D K DIFQ(N)"
 S ^UTILITY($J,9,0)=" L  S DUZ=DIDUZ W:"_(DIFRTX>0)_" !"_$S(Q:",$C(7),""OK, I'M DONE."",!",1:"")_",""NO""_$P(""TE THAT FILE"",U,DSEC)_"" SECURITY-CODE PROTECTION HAS BEEN MADE"""
 I 'Q S ^UTILITY($J,9.1,0)=" D ^"_Q_",NOW^%DTC S DIFROM(""INIT"")=%"
 S ^UTILITY($J,9.11,0)=" I DIFROM F DIF=1:2:"_DIFRTX_" S %=^UTILITY(""DIF"",$J,DIF),N=+$P(%,"";"",3) I N,$P(%,"";"",8)=""y"" S ^DD(N,0,""VR"")=DIFROM"
 S ^UTILITY($J,9.12,0)=" I DIFROM(0)>0 F %=""PRE"",""INI"",""INIT"" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)"
 S ^UTILITY($J,9.13,0)=" I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN"
 S ^UTILITY($J,9.2,0)=" S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),""VERSION"")=DIFROM G Q^DIFROM0"
 S ^UTILITY($J,9.3,0)="D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_""0)"")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)"
 S ^UTILITY($J,9.4,0)=" S DIFQR=DIFQR(+N) I ^DD(""VERSION"")>17.5,$D(^DD(+N,0,""DIK""))#2 S X=^(""DIK""),Y=+N,DMAX=^DD(""ROU"") D EN^DIKZ"
 S ^UTILITY($J,9.5,0)=" I DIFQR D IXALL^DIK:$O(@(DIK_""0)"")) W ""."""
 S ^UTILITY($J,9.6,0)=" Q"
 S ^UTILITY($J,9.7,0)="R G REP^"_E_2
 F DD=1:1 S E=$T(T+DD) Q:E=""  S E=$E(E,4,999) S:E="IXF ;;" E=E_$P(DPK(0),U,1,2)_";"_DUZ S ^UTILITY($J,9+DD,0)=E
 S DIFROM=10 G ^DIFROM6
T ;;
 ;; ;
 ;;1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 ;; W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 ;; I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 ;; I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 ;; S DIFQ(N)=$P(DIF(I),";",7)'="n"
 ;; I $L(Z) W $C(7),!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 ;; S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 ;; I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
 ;;S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 ;; I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 ;; S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 ;; Q
 ;;Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;; ;
 ;;PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 ;; Q
 ;; ;
 ;;IXF ;;

DIFROM6
DIFROM6 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT' ;03:06 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DH=" ;",Q=" K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT"
 S ^UTILITY($J,.3,0)=" S DIOVRD=1,U=""^"",DIFQ=0,DIFROM="""_$S($D(DPK(1)):DPK(1),1:0)_""" W !,""This version"_$S($D(DPK(1)):" (#"_DPK(1)_")",1:"")_" of '"_DTL_"INIT' was created on "_DIFROM(1)_""""
 S ^UTILITY($J,1,0)=" I $D(^DD(""VERSION"")),^(""VERSION"")'<"_+DRN_" G GO"
 S ^UTILITY($J,2,0)=" ;W !,""FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...."" D N^DINIT"
 S ^UTILITY($J,2.9,0)=" I ^DD(""VERSION"")<"_+DRN_" W !,""but I need version "_+DRN_" of the VA FileMan!"" G Q"
 S ^UTILITY($J,3,0)="GO ;"
 S ^UTILITY($J,3.5,0)="EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM"
 S ^UTILITY($J,3.6,0)=" S DIFQ=0 K DIRUT,DTOUT,DUOUT"
 S ^UTILITY($J,3.7,0)=" F DIFRIR=1:1:"_DIFRIR_" S DIFRRTN="_""""_U_DIFRRN_""""_"_$E("_""""_$E(DIFRRXT,1,DIFRIR)_""""_",DIFRIR) D @DIFRRTN"
 S ^UTILITY($J,3.8,0)=" W:"_(DIFRTX>0)_" !,""I AM GOING TO SET UP THE FOLLOWING FILE"_$E("S",X>1)_":"" F I=1:2:"_DIFRTX_" S DIF(I)=^UTILITY(""DIF"",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)"
 S X=$E(DTL_"INIT",1,7)
 S ^UTILITY($J,4,0)=" S DIFROM="""_$S($D(DPK(1)):DPK(1),1:0)_""" D PKG:'$D(DIFROM(0)),^"_X_"1 G Q:'$D(DIFQ) S DIK(0)=""AB"""
 S ^UTILITY($J,6,0)=" K DIFQR D ^"_X_"2,^"_X_3,X=0
 D VERSION^DI
 S ^UTILITY($J,.6,0)=" W !?9,""("_$S($D(^DD("SITE")):"at "_^("SITE")_",",1:"")_" by "_X_")"",!"
 I DPK>0,$D(^DIC(9.4,DPK,"PRE")),$P(^("PRE"),U)]"" S ^UTILITY($J,3.1,0)=" W !,""I HAVE TO RUN AN ENVIRONMENT CHECK ROUTINE."" D PKG,^"_$P(^("PRE"),U)_" Q:'$D(DIFQ)  D NOW^%DTC S DIFROM(""PRE"")=%"
 K ^UTILITY(U,$J),E S D=-9999,DNAME=DTL_"INIT",DL=0 D 2^DIFROM3
 I $G(DPK)>0,$D(^%ZOSF),$D(^%ZTSK) N DIFRINIS D SETUP^DIFROM7(DTL_"INIT",.DIFRINIS) W:$G(DIFRINIS)["INIS" !,DTL,"INIS HAS BEEN FILED..."
 Q
 ;
INTEG W !,"..." S X=0,%X="F %Y=1:1:DD S D=$A(DNAME,%Y)*%Y+D"
 F XCNP=XCNP:0 S X=$O(^UTILITY($J,X)) Q:X=""  W "." X "ZL @X S D=0 F Y=1:1 S DNAME=$T(+Y),DD=$L(DNAME) X %X I 'DD S ^UTILITY(""DINTEG"",$J,X)=D ZL DIFROM6 Q"
 Q

DIFROM7
DIFROM7 ;SFISC/(SLC/STAFF)-SITE TRACKING INSTALL BULLETIN ;01:06 PM  23 Aug 1993
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SETUP(ROUTINE,STATUS) ;
 K ^TMP($J) N LINE,LINE1,LINE2,NUM,OK,ROUTINIS,TXT
 D LOAD(ROUTINE,"^TMP($J,",0)
 I $P($P(^TMP($J,1,0),";")," ")'?1U1.3UN1"INIT" S STATUS="not changed" Q
 S ROUTINIS=$P(ROUTINE,"INIT")_"INIS"
 S (OK,LINE)=0 F  S LINE=$O(^TMP($J,LINE)) Q:LINE<0  S TXT=^(LINE,0) S:TXT[("PAC^"_ROUTINIS) OK=2 Q:OK=2  I TXT["=DIFROM G Q^DIFROM" S OK=1 Q
 I 'OK S STATUS="not installed" Q
 I OK=1 D
 .S ^TMP($J,LINE-.9,0)=" I DIFROM,$D(^%ZTSK) S X="""_ROUTINIS_""" X ^%ZOSF(""TEST"") D:$T PAC^"_ROUTINIS_"($T(IXF),.DIFROM)"
 .D SAVE(ROUTINE,"^TMP($J,",0)
 .S STATUS="site tracking installed"
 I OK=2 S STATUS="already installed"
 S LINE1=ROUTINIS_$P(^TMP($J,1,0),ROUTINE,2,99),LINE2=^TMP($J,2,0) K ^TMP($J)
 S ^TMP($J,1,0)=LINE1,^TMP($J,2,0)=LINE2
 F NUM=3:1 S LINE=$P($T(NMSPINIS+NUM),";",3,99) Q:LINE=""  D
 .I LINE["@@@@@@" S LINE=$P(LINE,"@@@@@@")_ROUTINIS_$P(LINE,"@@@@@@",2)
 .S ^TMP($J,NUM,0)=LINE
 D SAVE(ROUTINIS,"^TMP($J,",0)
 S STATUS=STATUS_" -- "_ROUTINIS_" saved"
 K ^TMP($J)
 Q
LOAD(X,DIF,XCNP) X ^%ZOSF("LOAD")
 Q
SAVE(X,DIE,XCN) X ^%ZOSF("SAVE")
 Q
NMSPINIS ;;
 ;;
 ;;
 ;;PAC(PKG,VER) ; called from package init (DIFROM7 created this routine)
 ;; ; PKG = $T(IXF) of the INIT routine.
 ;; ; VER is an array that is contained in DIFROM from the INIT routine
 ;; ;
 ;; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("@@@@@@",$J)
 ;; ;
 ;; ; Site tracking updates only occur if run in a VA production primary domain
 ;; ; account.
 ;; I $G(^XMB("NETNAME"))'[".VA.GOV" Q
 ;; Q:'$D(^%ZOSF("UCI"))  Q:'$D(^%ZOSF("PROD"))
 ;; X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q
 ;; ;
 ;; S SERVER="S.A5CSTS@FORUM.VA.GOV"
 ;; S PACKAGE=$P($P(PKG,";",3),U)
 ;; S SITE=$G(^XMB("NETNAME"))
 ;; S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown"
 ;; D  ; check if ok to use kernel functions
 ;; .S X="XLFDT" X ^%ZOSF("TEST") I $T D  Q
 ;; ..S NOW=$$HTFM^XLFDT($H)
 ;; ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3)
 ;; ..S START=$$FMTE^XLFDT(START)
 ;; ..S DATE=NOW\1
 ;; ..S NOW=$$FMTE^XLFDT(NOW)
 ;; .D NOW^%DTC S NOW=%,DATE=X
 ;; .S RUN="" ; don't bother to compute
 ;; .S Y=START D DD^%DT S START=Y
 ;; .S Y=NOW D DD^%DT S NOW=Y
 ;; ;
 ;; ; Message for server
 ;; S ^TMP("@@@@@@",$J,1,0)="PACKAGE INSTALL"
 ;; S ^TMP("@@@@@@",$J,2,0)="SITE: "_SITE
 ;; S ^TMP("@@@@@@",$J,3,0)="PACKAGE: "_PACKAGE
 ;; S ^TMP("@@@@@@",$J,4,0)="VERSION: "_VER
 ;; S ^TMP("@@@@@@",$J,5,0)="Start time: "_START
 ;; S ^TMP("@@@@@@",$J,6,0)="Completion time: "_NOW
 ;; S ^TMP("@@@@@@",$J,7,0)="Run time: "_RUN
 ;; S ^TMP("@@@@@@",$J,8,0)="DATE: "_DATE
 ;; ;
 ;; ; Data is sent to server on FORUM - S.A5CSTS
 ;; S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""@@@@@@"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION"
 ;; D ^XMD
 ;; K ^TMP("@@@@@@",$J)
 ;; Q
 ;;

DIFROMH
DIFROMH ;SFISC/XAK-HELP FOR DIFROM ;03:19 PM  7 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;HELP FOR OPTIONS, BULLETINS, ETC.
 W !!?5,"YES means that you want to bring the ",$P(^DIC(DL,0),U)
 W "S in this namespace."
 W !?5,"NO means that you want to leave them out."
 Q:DL'=9.8  W !?5,"This question refers to entries in the ROUTINE documentation file."
 W !!?5,"Also, if you are building a network mail INIT, you must answer",!?5,"YES if you wish to include routines other than just the INIT",!?5,"routines (such as pre and post-inits) into the network mail message."
 Q
R ; HELP FOR PREFIX
 W !!?5,"This is a unique 2 to 4 character prefix beginning with an uppercase"
 W !?5,"letter and followed only by uppercase letters or numbers." Q:X'?1"??".E
 W !?5,"If this is an established package, you may enter one of the prefixes"
 W !?5,"listed in the left column below."
 S DIC="^DIC(9.4,",DIC(0)="QE",DIC("W")="W ?10,$P(^(0),U)",D="C",DILN=15,DZ="??" D DQ^DICQ K DIC,DIZ,DILN Q
 ;
R1 ; HELP FOR RTN NAME
 W !!?5,"Answer YES if you want to create a program called "_DTL_"INIT"
 W:$D(Q) !?5,"even though there already is one on file.  (It will be overwritten.)"
 W !?5,"Answer NO if you don't want to do this." Q
 ;
S ; HELP FOR SECURITY CODES
 W !!?5,"YES means you want to include the security protection currently"
 W !?5,"on the files in the initialization routines.  A recipient of"
 W !?5,"this package will be able to decide whether or not to accept"
 W !?5,"these codes."
 W !?5,"NO means you do not want to include security codes."
 Q
M ; HELP FOR MAX RTN SIZE
 W !!?5,"Enter the maximum number of characters each routine should"
 W !?5,"contain.  This number must be between 2000 and 9999."
 Q
 ;
MSG ; HELP FOR MAILMAN MESSAGE
 W !!?5,"YES means that you are going to send this Package over"
 W !?5,"the Network as a message."
 W !?5,"NO means that you are going to generate routines."
 Q
Q1 ; HELP FOR SCRAMBLE PASSWORD
 W !?5,"The scramble password is a private code, which must be "
 W !?5,"exactly correct for a reader to to see the message legibly"
 W !?5,"It may be from 3 to 20 characters long.  Upper and lower"
 W !?5,"case characters are treated as the same.",! Q
 ;
Q3 ; HELP FOR SCRAMBLE HINT
 W !?5,"A scramble hint is used to suggest to the reader what"
 W !?5,"the scramble password is.  Since the password is not"
 W !?5,"recoverable after it is entered, the hint can be a "
 W !?5,"helpful reminder to the reader of the message.  The"
 W !?5,"hint will be shown to the recipient just before he "
 W !?5,"is asked to enter the password.",! Q
R3 ;DATA DICTIONARIES
 W !!?5,"Enter YES if you wish to transport dictionaries"
 W !?5,"or NO if you just want to Transport Options, Keys, etc."
 Q
NOPKG ; TEMPLATES WITH NON-PACKAGE FILE PREFIX
 W !!?5,"If YES, then ALL of the templates and forms belonging to the files"
 W !?5,"selected will be included in the initialization routines."
 W !?5,"If NO, only NAMESPACED templates and forms will be included.",!
 Q

DIFROMH1
DIFROMH1 ;SFISC/XAK-HELP FOR ANSWERING DIFROM PROMPTS ;03:15 PM  28 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
REP ;CHANGING YOUR FILE NAME
 W !!?5,"If YES, this will change the existing file name"
 W !?5,"to the incoming file name."
 W !?5,"If NO, it then will go on to the next Question.",!
 Q
CHG ;KEEPING YOUR OLD DATA
 W !!?5,"This allows you to keep your old data if you wish."
 W !?5,"I suggest if you get to this"
 W !?5,"question Just Default to the Question.",!
 Q
TEMP ;DELETING THE TEMPLATES
 W !!,"This will allow you to Delete or Keep the"
 W !,"(Sort,Print,Input) Templates if you wish.",!
 Q
AG ;DELETING FILES THAT ARE THE SAME
 W !!?5,"Enter Yes if you wish to Delete your file"
 W !?5,"This will overwrite your file with my file"
 W !?5,"If you wish to save your file please say"
 W !?5,"NO.  It will then Quit the INIT Process.",!
 Q
PKG ;ACCEPT DEFAULT DEFINITION
 W !!?5,"YES means that the information currently in the Package"
 W !?5,"File will be used to generate the package.  You will not be"
 W !?5,"to alter it."
 W !?5,"NO means that you will be able to define the package as you"
 W !?5,"proceed with the DIFROM."
 Q
L ;DISPLAY CURRENT PKG DEFN
 N %A W ! D WAIT^DICD
 S DIC=9.4,L=0,BY="@NUMBER",FR=DPK,TO=DPK,FLDS="[DI-PKG-DEFAULT-DEFINITION]",IOP="HOME" D EN1^DIP
 K B,P,DP,DIJ,%9
 Q
CUR ;HELP FOR SEEING PACKAGE
 W !!?5,"YES means that the package definition will be displayed to"
 W !?5,"you on your current device."
 W !?5,"NO means that you will continue generating the package.",!
 Q
DD ;HELP FOR OVERWRITING DD'S
 W !!?5,"YES means that the current data definitions will be overwritten"
 W !?5,"with the ones in these routines."
 W !?5,"NO means that only new data fields will be added."
 Q
DTA ;HELP FOR ADDING DATA
 W !!?5,"YES means that the data coming in with these inits will"
 I DIF W !?5,"replace the data on file if a match is found."
 E  W !?5,"only be added if there is no data on file."
 W !!?5,"Entries will be added if they do not match exactly"
 W !?5,"on Name and Identifiers."
 W !!?5,"NO means that everything will be left as is."
 Q
VER ;HELP FOR VERSION NO.
 W !!?5,"Package Version No. must be entered to put onto the second"
 W !?5,"line of the INIT routines."
 W !!?5,"Format can be either the old type of version no. nnn.nn",!,?5,"or the new type, nnnXnn where X is either T for test phase",!?5,"or V for verification phase." Q
PNM ;HELP FOR PACKAGE NAME
 W !!?5,"Enter the Package Name to go on the second line of the INIT routines." Q
VDT ;HELP FOR VERSION DATE
 W !!?5,"Enter the Distribution Date for this Package, to go on the second",!?5,"line of the INIT routines.  It should match the version date",!?5,"on the other routines being sent with this package." Q

DIFROMS
DIFROMS ;SFISC/DCL-DIFROM SERVER DD/DATA IN/OUT;09:47 AM  19 Jan 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
DDOUT(DIFRFILE,DIFRFLG,DIFRFIA,DIFRTA,DIFRMSGR) ; DD OUT TO TARGET ARRAY
 ;FILE,FLAGS,FIA_ARRAY,TARGET_ARRAY,MSG_ROOT
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA"))
 D EN^DIFROMS1
 G EXIT
 Q
DDIN(DIFRFILE,DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; DD IN FROM SOURCE ARRAY
 ;FILE,FLAGS,FIA_ARRAY,SOURCE_ARRAY,MSG_ROOT
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA"))
 N DIOVRD S DIOVRD=1
 D EN^DIFROMS2
 G EXIT
 Q
DATAOUT(DIFRFILE,DIFRFLG,DIFRFIA,DIFRTA,DIFRMSGR) ; DATA OUT
 ;FILE,FLAGS,FIA_ROOT,TARGET_ARRAY_ROOT,MSG_ROOT
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA"))
 N DIFRERRC
 D EN^DIFROMS3
 I $G(DIFRERRC) S DIERR=DIFRERRC
 G EXIT
 Q
DATAIN(DIFRFILE,DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; DATA IN
 ;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA"))
 N DIOVRD S DIOVRD=1
 D EN^DIFROMS4
 G EXIT
 Q
 ;
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMS1
DIFROMS1 ;SFISC/DCL-MOVE DD TO TARGET ARRAY;8/3/95  13:33
 ;;21.0;VA FileMan;**10**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
EN ;
 I '$D(@DIFRFIA) D ERR(1) Q
 G:$G(DIFRFILE) FCHK
 S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
 Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
FILE N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
 N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
 S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1))
 S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
 S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y"
 S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
 I DIFRFDD!DIFRPFD D
 .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
 .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
 .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2)
 .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
 .S @DIFRTA@("^DIC",DIFRFILE,"B",@DIFRFIA@(DIFRFILE),DIFRFILE)=""
 .Q
 I DSEC,(DIFRFDD!(DIFRPFD)) D
 .D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
 .K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
 .Q
 S DIFRD=0
 ;              * * Go through each DD and sub-DD * *
 F  S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0  S DIFRPFD=^(DIFRD)=0 D
 .S DIFRX=0
 .;         * * Merge each field DD to transport structure * *
 .;F  S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0  I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
 .F  S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0  I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
 ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
 ..N SEC F SEC=8,8.5,9 I $D(^DD(DIFRD,DIFRX,SEC)) D:SEC=8  I SEC>8,^(SEC)'="^",$P(^(0),"^",2)'["K",^(SEC)'="@" D
 ...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
 ...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
 ...Q
 ..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
 ..I 'DIFRPFD D
 ...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX)
 ...I 'SUBNUM Q
 ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
 ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))=""
 ...Q
 ..Q
 .;                * * Clean up x-refs in DDs * *
 .S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
 .S DIFRTART=$$OREF^DILF(DIFRQ)
 .F  S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="")  D:$P(DIFRQ,DIFRTART,2,99)[""""
 ..S DIFRK=1
 ..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
 ..F I=1:1 Q:I'<C  S G=$P(R2,",",F,I) Q:G=""  I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
 ..Q:DIFRK
 ..K @DIFRK
 ..Q
 .;           * * Build DD 0 node after x-ref clean up * *
 .;               for full DD or full sub-DD
 .I DIFRFDD!(DIFRPFD) D
 ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
 ..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
 ..Q
 .Q
 Q
 ;
SUBNUM(F,FD) ;
 ;Returns 0 if FielD in File is not multiple, otherwise subfile#.
 N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2)
 I 'SUBNUM Q 0
 I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0
 Q SUBNUM
 ;
ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
 ;;FIA Array Does Not Exist;1;9501
 ;;FIA File Number Invalid;2;9502

DIFROMS2
DIFROMS2 ;SFISC/DCL-INSTALL DD FROM SOURCE ARRAY;8/17/95  16:17
 ;;21.0;VA FileMan;**6,10**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
EN ;
 I '$D(@DIFRSA) D ERR(5) Q
 I '$D(@DIFRFIA) D ERR(4) Q
 G:$G(DIFRFILE) FCHK
 S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
 Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(6) Q
FILE ;
 N DIFR01,DIFR02,DIFRVR,DIFRFDD
 S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFR02=$G(^(2))
 I $TR($E(DIFR01),"NY","ny")="n" D ERR(1) Q
 S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
 I 'DIFRFDD,'$D(^DIC(DIFRFILE)) D ERR(7) Q
 I $D(^DIC(DIFRFILE,0)),$G(@DIFRFIA@(DIFRFILE,0,10))]"" X ^(10) I '$T D ERR(3) Q
 ;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q  ;INSTALL ONLY IF NEW * * PHASING OUT * *
 N %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z
 S DSEC=$P(DIFR02,"^") ; **>> add file security if new file only <<**
 ;delete DD wp text for file, field and x-ref description and field tech description
 ;also delete "NM" nodes when installing full DD at specified level
 I 'DIFRFDD D
 .K @DIFRSA@("DIFRNI",DIFRFILE)
 .N DIFRD
 .S DIFRD=DIFRFILE
 .F  S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 ..Q:$$UP(DIFRSA,DIFRFILE,DIFRD)
 ..S @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)=""
 ..N DIFRNGF,DIFRNGFD
 ..S DIFRNGF=+$G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
 ..S DIFRNGFD=.01 F  S DIFRNGFD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)) Q:DIFRNGFD=""  Q:+$P($G(^(DIFRNGFD,0)),U,2)=DIFRD
 ..I DIFRNGFD'="" K @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)
 ..Q
 .Q
 K:DIFRFDD ^DIC(DIFRFILE,"%D")
 S DIFRD=0
 F  S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
 .K:$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10 ^DD(DIFRD,0,"NM")
 .S DIFRFLD=0
 .F  S DIFRFLD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD)) Q:DIFRFLD'>0  D
 ..K ^DD(DIFRD,DIFRFLD,21),^(23)
 ..S DIFRX=0
 ..F  S DIFRX=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX)) Q:DIFRX'>0  D
 ...K ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D")
 ...Q
 ..Q
 .Q
 I DIFRFDD F DIFRX="^DIC","^DD" D
 .;I DIFRX="^DIC",'DIFRFDD Q
 .N X
 .I DIFRX="^DIC",$G(^DIC(DIFRFILE,0))]"" S X=$P(^(0),"^",3,9)
 .M @DIFRX=@DIFRSA@(DIFRX,DIFRFILE)
 .I DIFRX="^DIC",$G(X)]"" S $P(^DIC(DIFRFILE,0),"^",3,9)=X
 .I DSEC,$D(@DIFRSA@("SEC",DIFRX,DIFRFILE)) M @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE)
 .Q
 I 'DIFRFDD D
 .N DIFRD
 .S DIFRD=0
 .F  S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 ..I $D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
 ..M ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD)
 ..I DSEC,$D(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)) M ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)
 ..Q
 .Q
 S DIFRD=0 F  S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
 .S D=DIFRD,DIK="A" F  S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 .S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 .I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," D IXALL^DIK
 .Q
 I 'DIFRFDD D  G DIKZ
 .Q:'$D(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01))
 .S $P(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE)
 .Q
 S DIFRGL=^DIC(DIFRFILE,0,"GL"),DIFRDIC=$P(^DIC(DIFRFILE,0),U,1,2)
 S $P(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0)
 I DIFRFDD,+$G(@DIFRFIA@(DIFRFILE,0,"VR")) S DIFRVR=^("VR") D
 .S ^DD(DIFRFILE,0,"VR")=$P(DIFRVR,"^")
 .S ^DD(DIFRFILE,0,"VRPK")=$P(DIFRVR,"^",2)
 .Q
 S DIFRDATA=$D(@(DIFRGL_"0)")),^(0)=DIFRDIC_"^"_$S(DIFRDATA#2:$P(^(0),"^",3,9),1:"^")
DIKZ I $D(^DD(DIFRFILE,0,"DIK")) D
 .N %X,DIKJ,DIR,DMAX,X,Y,DIFRDIKA
 .D EN2^DIKZ(DIFRFILE,"",^DD(DIFRFILE,0,"DIK"),^DD("ROU"),"DIFRDIKA")
 .I $D(DIFRDIKA) M @DIFRSA@("DIKZ",DIFRFILE)=DIFRDIKA
 .S @DIFRSA@("DIKZ",DIFRFILE)=^DD(DIFRFILE,0,"DIK")
 .Q
 I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE)) D
 .N DIFRD
 .S DIFRD=0
 .F  S DIFRD=$O(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 ..N DIFRERR S DIFRERR(1)=DIFRD
 ..D BLD^DIALOG(9512,.DIFRERR)
 ..Q
 .Q
 Q
 ;
UP(ROOT,FILE,DDN) ;Return 1 or 0 to install
 Q:FILE=DDN 1
 Q:$D(^DD(DDN)) 1
 Q:'$D(@ROOT@("UP",FILE,DDN)) 1
 N MP,PARENT,T,X
 S MP=0,X="",T=0
 F  S X=$O(@ROOT@("UP",FILE,DDN,X)) Q:X=""  S PARENT=+^(X) D  Q:T!(MP)
 .I $D(^DD(PARENT))!($G(@ROOT@("FIA",FILE,PARENT))=0) S:X=0 T=1 Q
 .S MP=1
 .Q
 Q T
 ;
ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
 ;;FIA Node Is Set To "No DD Update";1;9503
 ;;Already Exist On Target System (INSTALL ONLY IF NEW);2;9504
 ;;Did Not Pass DD Screen;3;9505
 ;;FIA Array Does Not Exist;4;9511
 ;;Distribution Array Does Not Exist;5;9506
 ;;FIA File Number Invalid;6;9507
 ;;Partial DD/File Does Not Already Exist On Target System;7;9508

DIFROMS3
DIFROMS3 ;SFISC/DCL- DATA TO DISTRIBUTION ARRAY;10:34 AM  19 Jan 1995;
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
EN ;
 I '$D(@DIFRFIA) D ERR(2) Q
 G:$G(DIFRFILE) FILE
 S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
 Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q  ;  * * * * PHASING OUT * * * *
FILE N DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX
 N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0
 S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y"
 I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q
 I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA)
 S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11))
 S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0  ;$NA/trans gbl $Q
 S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO"))
 S:DIFRRLR="" DIFRRLR=DIFROOT
 I $D(@DIFRRLR)'>9 D ERR(4) Q
 N Y
 F  S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0  D
 .I '$D(@DIFROOT@(DIFRDA,0)) D  Q
 ..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE
 ..D BLD^DIALOG(9513,.DIFRERR)
 ..Q
 .I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T  ;set *NAKED* and *Y*
 .M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA)
 .Q
 S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE))  ;$NA/trans gbl/$Q
 S DIFRTART=$$OREF^DILF(DIFRQ)
 F  S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="")  D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR)
 .K R1
 .S DIFRK=1
 .S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
 .F I=1:1 Q:I>C  S G=$P(R2,",",F,I) Q:G=""  I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1(R1)=G,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
 .I DIFRPR,DIFRK,'(R1#2) D  Q  ;RESOLVE POINTERS
 ..D  Q:DIFR2DD'>0
 ...I R1'>3 S DIFR2DD=DIFRFILE Q
 ...S R3=""
 ...F I=0:1:R1-3 S R3=R3_R1(I)_","
 ...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2)
 ...Q
 ..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2
 ..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE))
 ..S DIFRPCE=0
 ..F  S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE=""  D:DIFRPCE>0
 ...Q:$P(@DIFRQ,"^",DIFRPCE)=""
 ...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)=""
 ...;CREATE IENS * * * * * * * * * * * * * * * * *
 ...F  S I=$O(R1(I),-1) Q:I=""  S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_","
 ...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0)
 ...D DIERR
 ...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD)
 ...D DIERR
 ...I DIFRFRV']"" D  Q
 ....N DIFRERR
 ....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD
 ....D BLD^DIALOG(9514,.DIFRERR)
 ....D DIERR
 ....Q
 ...S DIFRFRVX="FRV1"
 ...; If .01 field on file level is a pointer use "FRV0" subscript
 ...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0"
 ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV
 ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE,"F")=$S($P(DIFRDD0,"^",2)["P":";"_$P(DIFRDD0,"^",3),$P(DIFRDD0,"^",2)["V":"1;"_$P($P(@DIFRQ,"^",DIFRPCE),";",2),1:"")
 ...Q
 ..Q
 ..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK
 ..;  IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD
 ..;  AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR.
 ..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS
 ..Q
 .Q:DIFRK
 .K @DIFRK
 .Q
 Q
 ;
DIERR I $G(DIERR) S DIFRERRC=$$ERRC($G(DIFRERRC),DIERR) K DIERR
 Q
 ;
ERRC(X,Y) ;
 S X=$G(X),Y=$G(Y)
 S $P(X,"^")=+X+Y,$P(X,"^",2)=$P(X,"^",2)+$P(Y,"^",2)
 Q X
 ;
ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y  D BLD^DIALOG(Y) Q
 ;;FIA Node Is Set To "No Data";1;9509
 ;;FIA Array Does Not Exist;2;9501
 ;;;3;
 ;;Records Do Not Exist;4;9510
 ;;FIA File Number Invalid;5;9502

DIFROMS4
DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY;03:10 PM  14 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
EN ;
 I '$D(@DIFRFIA) D ERR(2) Q
 ;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2
 G:$G(DIFRFILE) FILE
 S DIFRFILE=0 F  S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0  D FILE
 Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q  ;  * * * PHASING OUT * * *
FILE N DIFRS,DIFRSCR,DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR
 N DIFRQ,DIFRTART,D,DDF,DDT,DTO,DFR,D0,DA,DKP,DIFRFRV,DIFRFRV1,DIFRFRV2
 N DTL,DMRG,DIU,DIK,DIIX,DIC,DFL,D0,D1,A,B,%H,V,W,X,Y,Z
 N DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS,DIFRNOAD,DIFRX
 I '$D(@DIFRFIA) D ERR(2) Q
 I $G(@DIFRFIA@(DIFRFILE,DIFRFILE)) D  Q
 .N DIFRERR S DIFRERR(1)=DIFRFILE
 .D BLD^DIALOG(9515,.DIFRERR)
 .Q
 S DIFROOT=@DIFRFIA@(DIFRFILE,0),DIFRDA=0
 S DIFR01=@DIFRFIA@(DIFRFILE,0,1),DIFR02=$G(^(2))
 I $P(DIFR02,"^",8)="" S $P(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA)
 S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRI"))  ;  * * * phasing out * * *
 S:DIFRRLR="" DIFRRLR=$NA(@DIFRSA@("DATA",DIFRFILE))
 I $D(@DIFRRLR)'>9 D ERR(4) Q
 S (D,DDF(1),DDT(0))=DIFRFILE
 ;
 ;   Recover from a failure in Replace Mode RE-INSTALL on target system
 I $D(@DIFRSA@("TMP")) D  K @DIFRSA@("TMP")
 .N DFR,DA,D0,DTO,DKP,Z
 .S DTO=0,DMRG=1,DTO(0)=DIFROOT,DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
 .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
 .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0))  S Z=^(0)
 .D I^DITR
 .Q
 ;
 F  S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0  D
 .S DTO=0,DMRG=1,DTO(0)=DIFROOT
 .S DFR(1)=$$OREF^DILF($NA(@DIFRSA@("DATA")))_"DDF(1),D0,"
 .S DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
 .S (DIFRDKPD,DIFRDKPR)=$S($TR($P(DIFR01,"^",8),"R","r")="r":1,1:0)
 .S (DIFRND0,DIFRDKP)=0
 .S:+DIFR02 (DIFRDKPD,DIFRDKPR)=0  ;if file is new Replace not needed
 .S DIFRDKPS=$P(DIFR02,"^",8)  ;save local data
 .S DIFRFRV=$TR($P(DIFR01,"^",5),"Y","y")="y"
 .S D0=DIFRDA,Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0)
 .K @DIFRSA@("TMP")
 .D I^DITR
 .Q:$D(@DIFRSA@("TMP"))'>9
 .;           re-index entry so old data can find it, in DITR1
 .D:DIFRND0
 ..N %,A,B,D0,DA,DIK,DDF,DDT,DFL,DFN,DFR,DKPKDMGR,DTL,DTN,DTO,I,V,W,X,Y,Z
 ..S DA=DIFRND0,DIK=DIFROOT
 ..D IX1^DIK
 ..Q
 .;           preserve data in local fields from old entry
 .S DIFRDKP=1,DIFRFRV=0
 .N DFR,DA,D0
 .;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0,"
 .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
 .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0))  S Z=^(0)
 .D I^DITR
 .Q
 K DDF,DDT,DDO,DFR,DFN,DTN,@DIFRSA@("TMP")
 ; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
 S DIK=DIFROOT,DIK(0)="AB"
 D IXALL^DIK:$O(@(DIK_"0)"))
 Q
ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y  D BLD^DIALOG(Y) Q
 ;;FIA Node Is Set To "No Data";1;9509
 ;;FIA Array Does Not Exist;2;9501
 ;;;3;
 ;;Records Do Not Exist;4;9510
 ;;FIA File Number Invalid;5;9502
 ;; *PARTIAL DD*, Data Transport Not Allowed

DIFROMS5
DIFROMS5 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES OUT;APR 13, 1995@14:31;
 ;;21.0;VA FileMan;**6,8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
EDEOUT ;EXTENDED DATABASE ELEMENTS OUT
 N DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT
 I $G(DIFRIEN)>0 G EDE
 N DIFRIENX,DIFRIENZ
 S DIFRIENX=$O(@DIFRLST@(0)),DIFRIENZ=$D(@DIFRLST@(DIFRIENX,0))#2,DIFRIENX=0
 F  S DIFRIENX=$O(@DIFRLST@(DIFRIENX)) Q:DIFRIENX'>0  D
 .I DIFRIENZ S DIFRIEN=+@DIFRLST@(DIFRIENX,0) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
 .S DIFRIEN=+@DIFRLST@(DIFRIENX) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
 Q
EDE ;
 ;  DIFRTRT=FULL ROOT IN DIST ARRAY
 ;  DIFRDSV=0TH NODE OF TEMPLATE
 ;         :.401, .4, .402
 ;         :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED
 ;         :.403
 ;         :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^
 ;         :.84
 ;         :DIALOG NUMBER^TYPE^INTERNAL PARM^PACKAGE FILE (pointer)
 ;  DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY
 ;  DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER
 ;         :.5 (FUNCTIONS)
 S DIFRTRT=$NA(@DIFRTA@(DIFRFILE,DIFRIEN))
 S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1)
 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ;
 ; For stand alone FileMan only - KIDS will do the Merge
 ; v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v
 ;
 I $G(DIFRSTNA) S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1) M @DIFRTRT=@DIFRGBL@(DIFRIEN)
 ;
 ; ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^
 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 I DIFRFILE=.5 Q  ;no processing necessary
 S DIFRDSV=$G(@DIFRTRT@(0)),DIFRF=$P(DIFRDSV,U,$S(DIFRFILE=.403:8,1:4))
 I DIFRDSV="" D  Q
 .N DIFRERR S DIFRERR(1)=DIFRFNAM,DIFRERR(2)=DIFRIEN
 .D BLD^DIALOG(9516,.DIFRERR)
 .Q
 I DIFRFILE=.84 G DIALOG
 S DIFRSEC=DIFRFLG'["S"
 I DIFRFILE=.403 G T403
 Q:'$D(@DIFRTRT@(0))  K ^("RD"),^("AB") K:DIFRFILE=.401 ^(1)
 S $P(@DIFRTRT@(0),U,5)="" S:'DIFRSEC ^(0)=$P(DIFRDSV,U,1,2)_U_U_DIFRF_U_U_U_U_$P(DIFRDSV,U,8,9)
 Q
 ;
T403 ;PROCESS FORMS AND EACH BLOCK IT CONTAINES
 S $P(DIFRDSV,U,4)="",$P(DIFRDSV,U,6)="" S:'DIFRSEC $P(DIFRDSV,U,2,3)=U
 S @DIFRTRT@(0)=DIFRDSV
 D T404
 K @DIFRTRT@("AZ"),@DIFRTRT@(40,"B"),^("C")
 N X
 S X=0
 F  S X=$O(@DIFRTRT@(40,X)) Q:X'>0  K @DIFRTRT@(40,X,40,"AC"),^("B")
 Q
 ;
T404 ;PROCESS BLOCKS
 ;    :.404
 ;    :BLOCK NAME^
 N DIFR1,DIFR2,D1,D2
 S D1=0
 F  S D1=$O(@DIFRTRT@(40,D1)) Q:'D1  I $D(^(D1,0)) S DIFR1=+$P(^(0),U,2) D
 .I $D(^DIST(.404,DIFR1,0)) D
 ..S $P(@DIFRTRT@(40,D1,0),U,2)=$P(^DIST(.404,DIFR1,0),U)
 ..M @DIFRTA@(.404,DIFR1)=^DIST(.404,DIFR1)
 ..K @DIFRTA@(.404,DIFR1,40,"B"),^("C"),^("D")
 ..Q
 .S D2=0
 .F  S D2=$O(@DIFRTRT@(40,D1,40,D2)) Q:'D2  I $D(^(D2,0)) S DIFR2=+^(0) D
 ..I $D(^DIST(.404,DIFR2)) D
 ...S $P(@DIFRTRT@(40,D1,40,D2,0),U)=$P(^DIST(.404,DIFR2,0),U)
 ...M @DIFRTA@(.404,DIFR2)=^DIST(.404,DIFR2)
 ...K @DIFRTA@(.404,DIFR2,40,"B"),^("C"),^("D")
 ...Q
 ..Q
 .Q
 Q
 ;
DIALOG ;
 Q:'$D(@DIFRTRT@(0))  K ^(4),^(3,"B")
 Q:$G(DIFRF)'>0
 S:DIFRF DIFRF=$P($G(^DIC(9.4,DIFRF,0)),"^"),$P(@DIFRTRT@(0),"^",4)=DIFRF
 Q

DIFROMS6
DIFROMS6 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES IN;03:07 PM  25 Mar 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
EDEIN ;EXTENDED DATABASE ELEMENTS IN
 N DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT
 I $G(DIFRIEN)>0 G EDE
 N DIFRIENX,DIFRIENZ
 S DIFRIENX=$O(@DIFRLST@(0)),DIFRIENZ=$D(@DIFRLST@(DIFRIENX,0))#2,DIFRIENX=0
 F  S DIFRIENX=$O(@DIFRLST@(DIFRIENX)) Q:DIFRIENX'>0  D
 .I DIFRIENZ S DIFRIEN=+@DIFRLST@(DIFRIENX,0) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
 .S DIFRIEN=+@DIFRLST@(DIFRIENX) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
 Q
EDE ;
 ;  DIFRTRT=FULL ROOT IN DIST ARRAY
 ;  DIFRDSV=0TH NODE OF TEMPLATE
 ;         :.401, .4, .402
 ;         :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED
 ;         :.403
 ;         :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^
 ;  DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY
 ;  DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER
 ;         :.5 (FUNCTIONS)
 S DIFRTRT=$NA(@DIFRTA@(DIFRFILE,DIFRIEN))
 ;
ERR(X,Y) ;
 S X(1)=X D BLD^DIALOG(Y,.X)
 Q

DIFROMSB
DIFROMSB ;SCISC/DCL-SILENT DIFROM/INSTALL BLOCKS;08:35 AM  22 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
BLKSIN(DIFRNAME,DIFRFLG,DIFRSA,DIFRMSGR) ;
 ;PACKAGE_NAME,FLAGS,SOURCE_ROOT,MSG_ROOT
 ;*
 ;PACKAGE_NAME=Package Name
 ;    (Required if Source Root is not passed) - Identifies the
 ;                 unique key subscript in the transport structure.
 ;*
 ;FLAGS=O
 ;    (Optional) - "O"=use Old calls (DIC)
 ;*
 ;SOURCE_ROOT=Source Array Root
 ;    (Optional) - Closed array reference which contain all the
 ;                 Blocks that are to be installed.
 ;    (Note) - Required if Package_Name is not passed.
 ;*
 ;MSG_ROOT=Closed Root for Error Messages
 ;    (Optional) - Array where messages such as errors will be
 ;                 returned.  If not passed, decendents of the ^TMP
 ;                 will be used.
 ;*
 I $G(DIFRNAME)=""&($G(DIFRSA))="" D ERR("PACKAGE NAME/SOUCE ROOT") Q
 N DIFRFILE,DIFRDA,DIFROLD,DIFRX,DIFRY,DIC,DA,DLAYGO,X,Y
 S DIFRFILE=.404,DIFRDA=0
 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN"))
 S DIFROLD=$G(DIFRFLG)["O"
 I DIFROLD S DLAYGO=DIFRFILE,DIC="^DIST(.404,",DIC(0)="LX" D  Q
 .F  S DIFRDA=$O(@DIFRSA@(.404,DIFRDA)) Q:DIFRDA'>0  S DIFRX=^(DIFRDA,0) D
 ..S X=$P(DIFRX,"^"),DIFRFL=$P(DIFRX,"^",2)
 ..K DA
 ..D ^DIC
 ..I Y>0 S DIFRY=Y D DELADD Q
 ..N DIFRERR S DIFRERR(1)=$P(DIFRX,"^")
 ..D BLD^DIALOG(9517,.DIFRERR)
 ..Q
 ; CODE FOR NEW CALLS                                           <<<***
 G EXIT
 Q
DELADD ;
 K ^DIST(.404,+DIFRY),DA,DIK
 M ^DIST(.404,+DIFRY)=@DIFRSA@(.404,DIFRDA)
 S DIK="^DIST(.404,",DA=+DIFRY
 D IX1^DIK
 I '$D(DD(+DIFRFL)) D
 .N DIFRERR S DIFRERR(1)=$P(DIFRX,"^"),DIFRERR(2)=DIFRFL
 .D BLD^DIALOG(9518,.DIFRERR)
 .Q
 Q
 ;
ERR(X) S X(1)=X D BLD^DIALOG(202,.X)
 Q
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMSC
DIFROMSC ;SCISC/DCL-EDE IN CONTINUE FPRE & FPOST ;08:38 AM  22 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FPRE ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 N DIOVRD S DIOVRD=1
 S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
 I DIFRFILE'>0 D BLD^DIALOG(9519) Q
 Q:DIFRFILE'=.403
 I $G(DIFRNAME)="" D BLD^DIALOG(9520) Q
 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN"))
 I DIFRFILE=.403 D  Q
 .N DIC,DIK,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y
 .S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404
 .S DIFRR=0
 .F  S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0  S DIFRX=^(DIFRR,0) D
 ..S DIFRL=$P(DIFRX,"^",2)
 ..S X=$P(DIFRX,"^")
 ..K DA
 ..D ^DIC
 ..I Y'>0 D  Q
 ...N DIFRERR S DIFRERR(1)=$P(DIFRX,"^")
 ...D BLD^DIALOG(9517,.DIFRERR)
 ...Q
 ..K ^DIST(.404,+Y)
 ..I '$D(^DD(+DIFRL)) D
 ...N DIFRERR S DIFRERR(1)=$P(DIFRX,"^"),DIFRERR(2)=DIFRL
 ...D BLD^DIALOG(9518,.DIFRERR)
 ...Q
 ..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR)
 ..S DIK=DIC,DA=+Y
 ..D IX1^DIK
 ..Q
 .Q
 Q
FPOST ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 N DIOVRD S DIOVRD=1
 Q
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMSD
DIFROMSD ;SFISC/DCL-DIFROM SERVER DD LIST(KIDS/BUILD FILE);08:33 AM  6 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
DD(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
 ;FILE, FLAGS, TARGET ARRAY
 ;FILE = File number
 ;FLAG = "W"  Include Word Processing DD numbers
 ;DIFRTA = Target Array in closed array root format where informaiton
 ;         is returned.
 ;         Returns a list of sub DD numbers.  A flag allows wp DD
 ;         numbers to also be returned.
 N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
 S DIFRFW=$G(DIFRFLG)'["W"
F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_"  "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0
E F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
 .S DIFRFD=0
 .F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  D
 ..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
 ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_"  (sub-file)"
 ..Q
 .Q
 Q
 ;
DDIOLDD(DIFRFILE,DIFRFLG) ;
 ;FILE,FLAGS
 ;FILE = File number
 ;FLAGS = None
 ;        Returns a list of all the valid DD numbers within a file
 ;        via a call to DDIOL.
 N I,X,Y
 K ^TMP("DIFROMSP",$J)
 D DD(DIFRFILE,"","^TMP(""DIFROMSP"",$J)")
 S (I,X)=0 F  S I=$O(^TMP("DIFROMSP",$J,DIFRFILE,I)) Q:I'>0  S Y=^(I),X=X+1,^TMP("DIFROMSP",$J,"DDIOL",X,0)=I_$J("",(20-$L(I)))_Y
 D EN^DDIOL("","^TMP(""DIFROMSP"",$J,""DDIOL"")")
 K ^TMP("DIFROMSP",$J)
 Q
 ;
CHKDD(DIFRFILE,DIFRDD,DIFRFLG) ;    $$    EXTRINSIC FUNCTION    $$
 ;Extrinsic; Pass file and DD numbers returns 1 if OK
 ; and 0 if not DD not part of File
 ;FILE,DD#
 ;FILE = File number
 ;DD# = File or sub-file number.
 ;      Used to determine if
 ;      the value in DD# is valid for FILE.
 ;FLAGS = "N"umber_"^"_"N"ame of field returned
 ;        Default returns a 1 (true) or 0 (false).
 Q:$G(DIFRDD)="" 0
 Q:$G(DIFRFILE)="" 0
 N DIFRARAY,N
 S N=$G(DIFRFLG)["N"
 D DD(DIFRFILE,"","DIFRARAY")
 I $D(DIFRARAY(DIFRFILE,DIFRDD)) Q:N DIFRDD_"^"_DIFRARAY(DIFRFILE,DIFRDD) Q 1
 Q 0
 ;
DDIOLFLD(DIFRDD,DIFRFLG) ;
 ;FILE/SUB_FILE,FLAGS
 ;FILE = File or sub-file number
 ;FLAGS = "M"ultiple fields excluded
 ;        "W"ord processing fields excluded
 ;        Returns a list of  valid field numbers within a file or
 ;        sub-file via a call to DDIOL.
 N I,M,W,X,Y,Z
 S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W"
 K ^TMP("DIFROMSP",$J)
 S (I,X)=0 F  S X=$O(^DD(DIFRDD,X)) Q:X'>0  S Y=$G(^(X,0)) D
 .I $P(Y,"^",2) D  Q:Y=""
 ..S Z=$P(^DD(+$P(Y,"^",2),.01,0),"^",2)
 ..I M,Z'["W" S Y="" Q
 ..I W,Z["W" S Y="" Q
 ..S $P(Y,"^")=$P(Y,"^")_$S(Z["W":"  (word-processing)",1:"  (multiple)")
 ..Q
 .S I=I+1,^TMP("DIFROMSP",$J,I,0)=X_$J("",(12-$L(X)))_$P(Y,"^")
 D EN^DDIOL("","^TMP(""DIFROMSP"",$J)")
 K ^TMP("DIFROMSP",$J)
 Q
 ;
FLDCHK(DIFRDD,DIFRFLD,DIFRFLG) ;     $$    EXTRINSIC FUNCTION     $$
 ;Check if field exist; return 1/FIELD#_NAME, true, or 0, false.
 ;FILE/SUB_FILE,FIELD,FLAGS
 ;FILE/SUB_FILE = File or sub-file number
 ;FIELD = Field number
 ;        If FIELD is valid, returns 1; Otherwise 0 is returned.
 ;FLAGS = "M"ultiple fields excluded
 ;        "W"ord processing fields excluded
 ;        "N"umber_"^"_"N"ame of field returned.
 ;         Default is to return 1 or 0.
 ;
 Q:$G(DIFRDD)="" 0
 Q:$G(DIFRFLD)="" 0
 N M,N,W,Z
 S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W",N=$G(DIFRFLG)["N"
 I $P($G(^DD(DIFRDD,DIFRFLD,0)),"^",2) S Z=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D  Q:N $S(Z:DIFRFLD_"^"_$P(^DD(DIFRDD,DIFRFLD,0),"^"),1:Z) Q Z
 .I M,Z'["W" S Z=0 Q
 .I W,Z["W" S Z=0 Q
 .S Z=1
 .Q
 I $D(^DD(DIFRDD,DIFRFLD,0))#2 Q:N DIFRFLD_"^"_$P(^(0),"^") Q 1
 Q 0

DIFROMSE
DIFROMSE ;SFISC/DCL-FILE ORDER TO RESOLVE POINTERS;07:27 AM  2 Jun 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;File Order List for Resolving Pointers
FOLRP(DIFRFLG,DIFRTA) ;FLAGS,TARGET_ARRAY ; Creates the "DIORD" subscript
 ;                structure in the transport array.
 ;FLAGS,TARGET_ARRAY
 ;*
 ;FLAGS = None
 ;*
 ;TARGET_ARRAY = CLOSED ROOT
 ;               This is the Transport Array Root.
 ;               "DIORD" is appended to the array root.
 ;               A ordered list of files is returned
 ;               in the target array.  Each file is given
 ;               a value to determine which file should have
 ;               pointers resolved.  After each file has been
 ;               assigned a value it is ordered by value then
 ;               by file number.  If files have the same value
 ;               the file number is then used to determine the
 ;               order.  This call is used after all the file
 ;               being transported are in the "FIA" structure.
 ;*
 Q:$G(DIFRTA)']""
 N DIFRCNT,DIFRDD,DIFRF,DIFRFILE,DIFRFLD,DIFRX
 S DIFRFILE=0
 K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J),@DIFRTA@("DIORD")
 F  S DIFRFILE=$O(@DIFRTA@("FIA",DIFRFILE)) Q:DIFRFILE'>0  D
 .D FSF^DIFROMSP(DIFRFILE,"","^TMP(""DIFROMSE"",$J)")
 .Q
 S DIFRFILE=0
 F  S DIFRFILE=$O(^TMP("DIFROMSE",$J,DIFRFILE)) Q:DIFRFILE'>0  D
 .S DIFRDD=0,^TMP("DIFRORD",$J,DIFRFILE)=0
 .F  S DIFRDD=$O(^TMP("DIFROMSE",$J,DIFRFILE,DIFRDD)) Q:DIFRDD'>0  D
 ..S DIFRFLD=0
 ..F  S DIFRFLD=$O(^DD(DIFRDD,DIFRFLD)) Q:DIFRFLD'>0  S DIFRX=$G(^(DIFRFLD,0)) D
 ...Q:$P(DIFRX,"^",2)
 ...Q:$P(DIFRX,"^",2)'["P"&($P(DIFRX,"^")'["V")
 ...S DIFRCNT=0
 ...I $P(DIFRX,"^",2)["V" D  G P
 ....S DIFRF=0 F  S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0  S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT+1
 ....Q
 ...I +$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2)=DIFRFILE S:$G(^TMP("DIFRORD",$J,DIFRFILE))'>DIFRCNT ^(DIFRFILE)=DIFRCNT Q
 ...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1
P ...S DIFRF=$O(^TMP("DIFRFILE",$J,"")) Q:DIFRF=""  S DIFRCNT=^(DIFRF) K ^(DIFRF)
 ...I $G(^TMP("DIFRORD",$J,DIFRF))'>DIFRCNT S ^(DIFRF)=DIFRCNT
 ...S DIFRX=^DD(DIFRF,.01,0)
 ...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1 G P
 ...G:$P(DIFRX,"^",2)'["V" P
 ...S DIFRF=0 F  S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0  S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT
 ...S DIFRCNT=DIFRCNT+1
 ...G P
 ...Q
 ..Q
 .Q
 S DIFRFILE=0
 F  S DIFRFILE=$O(^TMP("DIFRORD",$J,DIFRFILE)) Q:DIFRFILE'>0  S DIFRX=^(DIFRFILE),^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)=""
 S DIFRX="",DIFRCNT=1 F  S DIFRX=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX),-1) Q:DIFRX=""  D
 .S DIFRFILE=0 F  S DIFRFILE=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)) Q:DIFRFILE'>0  D
 ..S @DIFRTA@("DIORD",DIFRCNT)=DIFRFILE,DIFRCNT=DIFRCNT+1
 D KILL
 Q
KILL ;
 K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J)
 Q
 ;
CHK(DIFRFLG,DIFRSA,DIFRTA) ;CHECK FILES POINTED TO AGAINST FILES GOING OUT WITH DATA
 ;Compares the "DIORD" with the "FIA" structures
 ;FLAGS,SOURCE_ARRAY,TARGET_ARRAY
 ;*
 ;FLAGS = None
 ;*
 ;SOURCE_ARRAY = TRANSPORT ARRAY ROOT
 ;*
 ;TARGET_ARRAY = TARGET ARRAY ROOT
 ;               Returns a list of files that are pointed to
 ;               but not being exported.  This is used after
 ;               all the files being exported are in the "FIA"
 ;               structure.
 ;*
 Q:$G(DIFRSA)']""
 Q:$G(DIFRTA)']""
 N DIFRX,DIFRFILE
 S DIFRX=0
 F  S DIFRX=$O(@DIFRSA@("DIORD",DIFRX)) Q:DIFRX'>0  S DIFRFILE=^(DIFRX) D
 .Q:$D(@DIFRSA@("DATA",DIFRFILE))&($P($G(@DIFRSA@("FIA",DIFRFILE,0,1)),"^",5)="y")
 .S @DIFRTA@(DIFRFILE)=""
 .Q
 Q

DIFROMSF
DIFROMSF ;SCISC/DCL-SILENT DIFROM EXTENDED DATABASE FILES;08:41 AM  22 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
 ; * EXTENDED DATABASE ELEMENTS (EDE) *
EDEOUT(DIFRIEN,DIFRNAME,DIFRFLG,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR) ;
 ;ENTRY,PKGNAME,FLAGS,FIA_ARRAY,TARGET_ARRAY,LIST_ARRAY,MSG_ROOT
 I $G(DIFRNAME)']"" D ERR("PACKAGE NAME") Q
 N DIFRFILE
 S DIFRFILE=$S(DIFRFLG="F":.403,DIFRFLG="I":.402,DIFRFLG="P":.4,DIFRFLG="S":.401,DIFRFLG="$":.5,1:"")
 I DIFRFILE'>0 D ERR("FLAG") Q
 I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
 ;
 ;              >*>*>*> c h e c k   h e r e <*<*<*<
 ;
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA"))
 I $G(DIFRIEN)'>0&($G(DIFRLST)="") D ERR("NO IENs PASSED") Q
 I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D ERR("LIST DOES NOT CONTAIN IENs") Q
 D EDEOUT^DIFROMS5
 G EXIT
 ;
EDEIN ; * EXTENDED DATABASE ELEMENTS *
 Q
FPRE(DIFRFILE,DIFRNAME,DIFRSA) ; FILE-PRE
 K ^TMP("DIFROMS",$J)
 ;FILENUMBER,SUBSCRIPT_NAME(package name for KIDS),SOURCE_ARRAY
 S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
 I DIFRFILE'>0 D ERR("FILE NUMBER") Q
 Q:DIFRFILE'=.403
 I $G(DIFRNAME)="" D ERR("SUBSCRIPT NAME") Q
 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
 I DIFRFILE=.403 D  Q  ;If Forms bring in Blocks
 .N DIC,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y
 .S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404
 .S DIFRR=0
 .F  S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0  S DIFRX=^(DIFRR,0) D
 ..S DIFRL=$P(DIFRX,"^",2)
 ..S X=$P(DIFRX,"^")
 ..K DA
 ..D ^DIC
 ..I Y'>0 D ERR("UNABLE TO ADD "_$P(DIFRX,"^")_" BLOCK") Q
 ..K ^DIST(.404,+Y)
 ..I '$D(^DD(+DIFRL)) D ERR("BLOCK: "_$P(DIFRX,"^")_" installed but associated file "_DIFRL_" missing")
 ..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR)
 ..S DIK=DIC,DA=+Y
 ..D IX1^DIK
 ..Q
 .Q
 Q
 ;
EPRE(DIFRFILE,DIFRIEN,DIFROIEN,DIFRNAME,DIFRSA) ; ENTRY-PRE
 ;FILENUM,NEW_ENTRY_NUM,OLD_ENTRY_NUM,PKG/SUBSCRIPT_NAME,SOURCE_ARRAY
 ; Entry Pre - delete template on target system
 N DIFRRDA,DIFRX,DIFRF
 S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
 I DIFRFILE'>0 D ERR("FILE NUMBER") Q
 S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA)
 I DIFRIEN'>0 D ERR("ENTRY NUMBER") Q
 S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA)
 I DIFRIEN'>0 D ERR("OLD ENTRY NUMBER") Q
 I $G(DIFRNAME)="" D ERR("PACKAGE/SUBSCRIPT NAME MISSING") Q  ;GET VARIABLE FROM RON
 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
 ; build file root with entry number and kill entry on target system
 S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
 S DIFRX=$P(@DIFRRDA@(0),"^")
 S DIFRF=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",DIFRFILE=.401:"DIBT",DIFRFILE=.403:"DIST(.403,",DIFRFILE=.404:"DIST(.404,",1:"FUN")
 S ^TMP("DIFROMS",$J,DIFRF,DIFRX)=DIFRIEN
 K @DIFRRDA
 I DIFRFILE=.403 D  ;If Forms resolve Block Pointers
 .N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
 .S DIFRJ=0
 .F  S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ  I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D
 ..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0))
 ..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
 ..S DIFRL=0
 ..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL  S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D
 ...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D
 ....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
 ....Q
 ...Q
 ..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
 ..Q:DIFRA0=""
 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
 ..S (DIFRA1,DIFRA2)=0
 ..S DIFRL=0
 ..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL  S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1
 ..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
 ..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
 ..Q
 .Q
 Q
EPOST ; ENTRY-POST
 Q
FPOST ; FILE-POST      RECOMPILE TEMPLATES
 N DIFR,DIFR1,DIFR2,DMAX,X,Y
 K DIC,DLAYGO
 F DIFR="DIE","DIPT" D
 .I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 .E  S DISYS=^DD("OS")
 .Q:'$D(^DD("OS",DISYS,"ZS"))
 .S DIFR1=""
DZ1 .S DIFR1=$O(^TMP("DIFROMS",$J,DIFR,DIFR1)) Q:DIFR1=""
 .F DIFR2=0:0 S DIFR2=$O(^TMP("DIFROMS",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  D
 ..S Y=DIFR2
 ..I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD") D
 ...S DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 ...Q
 ..Q
 .G DZ1
 K ^TMP("DIFROMS",$J)
 Q
INITCHK ; check
 ;
 ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 Q
 ;
ERR(X) S X(1)=X D BLD^DIALOG(1700,.X)
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMSI
DIFROMSI ;SCISC/DCL-EDE IN ;09:21 AM  1 Feb 1995;
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FPRE(DIFRFILE,DIFRFLG,DIFRNAME,DIFRSA) ;
 G FPRE^DIFROMSC
EPRE(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA,DIFROIEN) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 N DIOVRD S DIOVRD=1
 N DIFRRDA,DIFRX
 S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
 I DIFRFILE'>0 D BLD^DIALOG(9521) Q
 S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA)
 I DIFRIEN'>0 D BLD^DIALOG(9522) Q
 S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA)
 I DIFROIEN'>0 D BLD^DIALOG(9523) Q
 I $G(DIFRNAME)="" D BLD^DIALOG(9524) Q
 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN"))
 S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
 S DIFRX=$P(@DIFRRDA@(0),"^")
 G:DIFRFILE=.84 DIALOG
 ;
 ; preserve security codes if template/form is not new
 I $G(DIFRFLG)'["N",DIFRFILE'=.5 D
 .N X,Y
 .S Y=@DIFRRDA@(0)
 .S X=@DIFRSA@(DIFRFILE,DIFROIEN,0),$P(X,U,3)=$P(Y,U,3),$P(X,U,6)=$P(Y,U,6),^(0)=X
 .Q
 ;
 I DIFRFILE'=.403 K @DIFRRDA
 E  D
 .Q:$G(DIFRFLG)["N"
 .N DA,DIC,DIK,DINUM,X,Y
 .S DIK="^DIST(.403,",DA=DIFRIEN
 .D ^DIK
 .S DIC="^DIST(.403,",DIC(0)="LX",X=DIFRX,DINUM=DIFRIEN
 .D FILE^DICN
 .Q
 I DIFRFILE=.403 D
 .N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
 .S DIFRJ=0
 .F  S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ  I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D
 ..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0))
 ..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
 ..S DIFRL=0
 ..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL  S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D
 ...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D
 ....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
 ....N DIFRX
 ....S DIFRX=0
 ....F  S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)) Q:DIFRX=""  S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,DIFRX)=^(DIFRX)
 ....Q
 ...Q
 ..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
 ..Q:DIFRA0=""
 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
 ..S (DIFRA1,DIFRA2)=0
 ..S DIFRL=0
 ..F  S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL  S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1 D
 ...N DIFRX
 ...S DIFRX=0
 ...F  S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL,DIFRX)) Q:DIFRX=""  S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)=^(DIFRX)
 ...Q
 ..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
 ..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
 ..Q
 .Q
 Q
DIALOG N DIFRF,DIFRX
 S DIFRF=$P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)
 I DIFRF]"" D
 .S DIFRF=$O(^DIC(9.4,"B",DIFRF,0)) I DIFRF,$O(^(DIFRF)) D  S DIFRF=""
 ..N DIFRERR S DIFRERR(1)=DIFRF,DIFRERR(2)=DIFRIEN
 ..D BLD^DIALOG(9525,.DIFRERR)
 ..Q
 .S $P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)=DIFRF
 F DIFRX=1,2,3,5,6 K @DIFRRDA@(DIFRX)
 Q
EPOST(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA) ;
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 N DIOVRD S DIOVRD=1
 I '$G(DIFRFILE)!('$G(DIFRIEN)) Q
 I $G(DIFRNAME)="" Q
 S:$G(DIFRSA)']"" DIFRSA=$NA(^XTMP("XPDI",DIFRNAME))
 N DA,DIFR,DIFR3,DIFROU,DIK,DMAX,DNM,X,Y,Z,DIFRTN
 S DIK=$$ROOT^DILFD(DIFRFILE),DA=DIFRIEN
 D IX1^DIK
 I DIFRFILE=.403,DIFRIEN D  Q
 .I $$VAL^DIFROMSS(DIFRFILE,DIFRIEN) D EN^DDSZ(DIFRIEN) Q
 .S DIFRTN=$P($G(^DIST(.403,DIFRIEN,0)),"^")
 .N DIFRERR S DIFRERR(1)=DIFRTN
 .D BLD^DIALOG(9527,.DIFRERR)
 .Q
 S DIFR=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",1:"")
 Q:DIFR=""
 I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 I '$D(^DD("OS",DISYS,"ZS")) D BLD^DIALOG(9526) Q
 S Y=DIFRIEN
 I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S (DIFROU,X)=^("ROUOLD"),DIFRTN=$P(^(0),"^") D:X]""
 .N %X,DIR,DMAX,X,Y,DIFRZTA
 .S DIFR3="DI"_$E(DIFR,3)_"Z"
 .I $$VAL^DIFROMSS(DIFRFILE,DIFRIEN) D  Q
 ..D @("EN2^"_DIFR3_"(DIFRIEN,"""",DIFROU,"""",""DIFRZTA"")")
 ..I $D(DIFRZTA) M @DIFRSA@(DIFR3,DIFRIEN)=DIFRZTA
 ..S @DIFRSA@(DIFR3,DIFRIEN)=DIFROU
 ..Q
 .N DIFRTT,DIFRERR S DIFRTT=$S(DIFRFILE=.4:"PRINT",1:"INPUT")
 .S DIFRERR(1)=DIFRTT,DIFRERR(2)=DIFRTN
 .D BLD^DIALOG(9528,.DIFRERR)
 .Q
 Q
FPOST ;
 G FPOST^DIFROMSC
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMSK
DIFROMSK ;SCISC/DCL-DIFROM SERVER DELETE PARTS ;02:55 PM  9 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
DEL(DIFRFILE,DIFRFLG,DIFRSA,DIFRMSGR) ;DELETE TEMPLATES
 ;FILE_NUMBER,FLAGS,SOURCE_ARRAY,MSG_ARRAY_ROOT
 ;*
 ;FILE_NUMBER = Template File Number
 ;
 ;     (Required) -
 ;                  Forms           .403   ^DIST(.403,   "DIST(.403,"
 ;                  Blocks          .404   ^DIST(.404,   "DIST(.404,"
 ;                  Input Template  .402   ^DIE(         "DIE"
 ;                  Print Template  .4     ^DIPT(        "DIPT"
 ;                  Sort Template   .401   ^DIBT(        "DIBT"
 ;*
 ;FLAGS = None at this time
 ;*
 ;SOURCE_ARRAY = Source Array where the list of internal
 ;               entry numbers are passed (IEN/DA).
 ;               Format is:   ARRAY(DA)=""
 ;               In this example "ARRAY" is passed.
 ;*
 ;MSG_ARRAY_ROOT = Array Root where the error message will be sent.
 ;*
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 D  I '$G(DIFRFILE) D BLD^DIALOG(9529) Q
 .I $G(DIFRFILE)'>0 Q
 .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402)!(DIFRFILE=.403)!(DIFRFILE=.404) Q
 .S DIFRFILE=0
 .Q
 I $G(DIFRSA)']"" D BLD^DIALOG(9506) Q
 I '$D(@DIFRSA) D BLD^DIALOG(9506) Q
 N DIFRDA,DIFROOT,DIFRCR
 S DIFRDA=0,DIFROOT=$$ROOT^DILFD(DIFRFILE),DIFRCR=$$ROOT^DILFD(DIFRFILE,"",1)
 I DIFROOT']"" D BLD^DIALOG(9529) Q
 ;I $$NPT(
 F  S DIFRDA=$O(@DIFRSA@(DIFRDA)) Q:DIFRDA'>0  D:$D(@DIFRCR@(DIFRDA,0))
 .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402) D DT(DIFROOT,DIFRDA) Q
 .I DIFRFILE=.404 D DFB(DIFRDA) Q
 .Q
 Q
 ;
DT(DIK,DA) ;Delete Template
 N DIFRFILE,DIFRSA,DIFRFLG,DIFRMSGR,DIFRDA,DIFRCR,DIFROOT
 N %,A,B,D0,I,W,X,Y,Z
 S Y=""
 D ^DIK
 Q
 ;
DFB(DA) ;Delete Forms and Blocks, within the specified form.
 D EN^DDSDFRM(DA)
 Q
 ;
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q
 ;

DIFROMSL
DIFROMSL(DIFRDD) ;SFISC/DCL-DIFROM SELECT FIELD FROM DD;08:37 AM  6 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;Select field from DD
 N D0,D1,D2,D3,DA,DIC,DO,DIE,%,C,DC,DH,DI,DIA,DR,DIEL,DILK,DIOV,DIP,DK,DL,DM,DP,DQ,DSC,DV,DW,DXS,Y
 S DIC="^DD("_DIFRDD_",",DIC(0)="AEMQ"
 D ^DIC
 S X=+Y

DIFROMSO
DIFROMSO ;SCISC/DCL-DIFROM SERVER EDE OUT;01:18 PM  8 Feb 1995;
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
 ; * EXTENDED DATABASE ELEMENTS (EDE) OUT *
EDEOUT(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR) ;
 ;FILE,IEN,FLAGS,PKGNAME,FIA_ARRAY,TARGET_ARRAY,RECORD_LIST,MSG_ROOT
 ;FILE=FILE NUMBER can only be:.5,.4,.401,.402,.403
 ;                            (.404 automatically comes with .403)
 ;     (Required) -
 ;                  Forms           .403   ^DIST(.403,   "DIST(.403,"
 ;                  Blocks          .404   ^DIST(.404,   "DIST(.404,"
 ;                  Input Template  .402   ^DIE(         "DIE"
 ;                  Print Template  .4     ^DIPT(        "DIPT"
 ;                  Sort Template   .401   ^DIBT(        "DIBT"
 ;                  Functions       .5     ^DD("FUNC",   "FUN"
 ;                  Dialog          .84    ^DI(.84,      ????
 ;
 ;                  Note: Blocks pointed to by Forms
 ;                        are automatically sent
 ;*
 ;IEN=INTERNAL ENTRY NUMBER - DA
 ;    (Required if LIST_ARRAY is not passed) - Identifies
 ;                 the internal entry number for the
 ;                 EDE being exported.
 ;*
 ;FLAGS="S" Strip Security Codes in Transport Structure (Do not send security codes for Forms and Templates)
 ;*
 ;PKGNAME=Package Name
 ;    (Required) - Identifies the unique key subscript
 ;                 in the export target array.
 ;*
 ;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT  * *NO LONGER USED* *
 ;    (Optional) - Close Input Array Reference
 ;    See DIFROM SERVER documentation for FIA array structure
 ;    definitions.  If undefined Target Array Root will be used
 ;    to append the "FIA" subscript  Default will be
 ;    ^XTMP("XPDT",DIFRNAME,"FIA")
 ;*
 ;TARGET_ARRAY=CLOSED_OUTPUT_ARRAY_ROOT
 ;    (Optional) - Closed Output Array Reference where the data will
 ;    be retuned to be temporarily stored for distribution.
 ;    ^XTMP("XPDT",DIFRNAME,"KRN") will be default.
 ;*
 ;LIST_ARRAY=LIST OF IENs PASSED BY VALUE
 ;    (Required if ENTRY not passed) - Closed Array
 ;    Reference where records for this type of template
 ;    exist.  Nodes can contain ,0).  If +value is greater
 ;    than 0 it is used, otherwise the subscript is
 ;    used as the IEN.
 ;*
 ;MSG_ROOT=CLOSED ARRAY REFERENCE
 ;    (Optional) - Closed array reference where messages such as
 ;    errors will be returned.  If not passed, decendents of ^TMP
 ;    will be used.
 ;*
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 I $G(DIFRNAME)']"" D BLD^DIALOG(9530) Q
 D
 .N X
 .S X=DIFRFILE
 .I X=.5!(X=.4)!(X=.401)!(X=.402)!(X=.403)!(X=.84) Q
 .S DIFRFILE=0
 .Q
 I DIFRFILE'>0 D BLD^DIALOG(9531) Q
 I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN"))
 ;*
 ;        * *DIFRFIA NO LONGER USED* *
 ;S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(^XTMP("XPDT",DIFRNAME,"FIA"))
 ;I '$D(@DIFRFIA) D BLD^DIALOG(9501) Q
 ;*
 I $G(DIFRIEN)'>0&($G(DIFRLST)="") D BLD^DIALOG(9531) Q
 I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D BLD^DIALOG(9532) Q
 S DIFRFLG=$G(DIFRFLG)
 N DIFRFNAM
 S DIFRFNAM=$P($P(".4;PRINT TEMPLATE^.401;SORT TEMPLATE^.402;INPUT TEMPLATE^.403;FORM^.404;BLOCK^.5;FUNCTION^.84;DIALOG",DIFRFILE_";",2),"^")
 D EDEOUT^DIFROMS5
 G EXIT
 ;
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q

DIFROMSP
DIFROMSP ;SFISC/DCL-DIFROM SERVER POINTER LIST;MAR 08, 1995@10:50;
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
POINTERS(DIFRFILE,DIFRFLG,DIFRPTA) ;FILENUMBER, POINTER X-REF TARGET ARRAY ROOT
 ;FILE, FLAGS, TARGET ARRAY
 S DIFRFLG=$G(DIFRFLG)
 N DIFRDDNS,DIFRALL
 S DIFRALL=DIFRFLG["A"
 D FP(DIFRFILE,"","DIFRDDNS")  ;ALL DD#s FOR FILE IN DIFRDDNS array
 S DIFRDDNS=0
 F  S DIFRDDNS=$O(DIFRDDNS(DIFRFILE,DIFRDDNS)) Q:DIFRDDNS'>0  D
 .D P(DIFRDDNS,DIFRFLG,$NA(@DIFRPTA@("P",DIFRFILE)))  ;set "P" x-refs in target array
 .Q
 Q
 ;
FP(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
 ;FILE, FLAGS, TARGET ARRAY
 N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
 S DIFRFW=$G(DIFRFLG)'["W"
F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_"  "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0
E F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
 .S DIFRFD=0
 .F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  D
 ..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
 ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_"  (sub-file)"
 ..Q
 .Q
 Q
 ;
P(DIFRPDD,DIFRFLG,DIFRPTA) ;DIFRPDD=DD#,DIFRPTA=TARGET ARRAY BY VALUE TO SET "P" X-REF
 ;FILE/SUB-DD#,FLAGS,TARGET_ARRAY
 N X,Y,PN,PIDF,PFILE,DIFRALL
 S DIFRFLG=$G(DIFRFLG),DIFRALL=DIFRFLG["A"
 I $G(U)'="^" N U S U="^"
 S X=$S(DIFRALL:0,1:.01)
 F  S X=$O(^DD(DIFRPDD,X)) Q:X'>0  I $D(^(X,0)),'$P(^(0),U,2),$P(^(0),U,2)["P" S Y=^(0) D
 .I 'DIFRALL,$D(^DD(DIFRPDD,0,"IX",X)) Q
 .S PN=0
 .S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
 .F  Q:$P($G(^DD(+$P($P(Y,U,2),"P",2),.01,0)),U,2)'["P"  S Y=^(0) D
 ..S PN=PN+1
 ..S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3)
 ..Q
 .S PIDF=0,PFILE=+$P($P(Y,U,2),"P",2)
 .F  S PIDF=$O(^DD(PFILE,0,"ID",PIDF)) Q:PIDF'>0  D
 ..S @DIFRPTA@(DIFRPDD,X,PN,"ID",PIDF)=""
 ..Q
 .;HERE FIND ALL REQUIRED ID OR ALL ID FOR POINTED TOO FILE
 .;AND LIST IN @DIFRPTA@(DIFRPDD,X,PN,"ID",FILEDNUMBER)
 .Q
 Q
 ;
PGL(DIFRFILE,DIFRFLG,DIFRTA) ;  RETURN GL NODES FOR POINTERS IN TARGET ARRAY
 ;FILE,FLAGS,TARGET ARRAY
 N DIFR,DIFRD,DIFRF,DIFRPGL,DIFRX
 Q:'$D(^DD(DIFRFILE))
 Q:$G(DIFRTA)']""
 D FSF(DIFRFILE,"","DIFRPGL")
 S (DIFR,DIFRD)=0
 F  S DIFRD=$O(DIFRPGL(DIFRFILE,DIFRD)) Q:DIFRD'>0  D
 .S DIFRF=.01  ;Dont select .01 fields
 .F  S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0  I $D(^(DIFRF,0)) S DIFRX=^(0) D
 ..Q:$P(DIFRX,"^",2)  ;Don't select Multiple/WP fields
 ..I $D(^DD(DIFRD,0,"ID",DIFRF)) Q  ;Don't select IDENTIFIER fields
 ..I $P(DIFRX,"^",2)["P"!($P(DIFRX,"^",2)["V") S @DIFRTA@("PGL",DIFRD,$$Q^DIQGU($P($P(DIFRX,"^",4),";")),$P($P(DIFRX,"^",4),";",2),DIFRF)=DIFRX Q
 ..;SEND WHOLD NODE NOT $P(DIFRX,"^",2) Q
 ..Q
 .Q
 Q
TP(DIFRFILE,DIFRFLG,DIFRTA) ; $$ Extrinsic Function - Test for Pointers OR Variable Pointers
 ;Returns 1 or 0, if pointers in file
 ;FILE,FLAGS,TARGET ARRAY
 ;If target array exist the entire list of fields being exported will be
 ;in array
 N DIFR,DIFRTMP,DIFRD,DIFRF,DIFRX
 S DIFRX=$G(DIFRTA)]""
 D FSF(DIFRFILE,"","DIFRTMP")
 S (DIFR,DIFRD)=0
 F  S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0  D  Q:DIFR
 .S DIFRF=.01  ; Do not include .01 fields
 .F  S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0  I $D(^(DIFRF,0)),'$P(^(0),"^",2),($P(^(0),"^",2)["P"!($P(^(0),"^",2)["V")),'$D(^DD(DIFRD,0,"ID",DIFRF)) S:'DIFRX DIFR=1 Q:DIFR  D
 ..S:DIFRX @DIFRTA@(DIFRD,DIFRF)=$S($P(^DD(DIFRD,DIFRF,0),"^",2)["P":"P",1:"V")
 ..Q
 .Q
 Q:DIFRX $D(@DIFRTA)>9
 Q DIFR
 ;
TL(DIFRFILE,DIFRFLG,DIFRSA) ; $$ Extrinsic Function - Test for local fields
 ;FILE,FLAGS,SOURCE_ARRAY - compares local DD with Transport DD
 ;Returns 1 or 0, if local changes exist
 ;RUN THIS AFTER DD IS INSTALLED ON TARGET SITE
 N DIFR,DIFRD,DIFRF,DIFRTMP
 D FSF(DIFRFILE,"","DIFRTMP")
 S (DIFR,DIFRD)=0
 F  S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0  D  Q:DIFR
 .S DIFRF=0
 .F  S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0  I $D(^(DIFRF,0)),'$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRF,0)) S DIFR=1 Q
 .Q
 Q DIFR
 ;
FSF(DIFRFILE,DIFRFLG,DIFRTA) ;File-Sub-File List
 ;FILE, FLAGS, TARGET ARRAY
 N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
 S DIFRFW=$G(DIFRFLG)'["W"
 S @DIFRTA@(DIFRFILE,DIFRFILE)="",DIFRFE=0
 F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
 .S DIFRFD=0
 .F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  D
 ..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q
 ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=""
 ..Q
 .Q
 Q

DIFROMSR
DIFROMSR ;SFISC/DCL-RESOLVE POINTERS ON TARGET SYSTEM;04:18 PM  18 Nov 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
RP(DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; Resolve Pointers on Target System
 ;The "FRV1" and "FRVL" structures within the
 ;transport array are used.
 ;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT
 ;*
 ;FLAGS=(RESERVED FOR LATER USE)
 ;    (Optional)
 ;                 None
 ;*
 ;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT
 ;    (Optional) - Close Input Array Reference
 ;    See DIFROM SERVER documentation for FIA array structure
 ;    definitions.  If undefined SOURCE_ARRAY will be used
 ;    by appending "FIA" to the source array root subscript.
 ;*
 ;SOURCE_ARRAY=CLOSED_INPUT_ARRAY_ROOT
 ;    (Required) - Closed Input Array Reference where the file data
 ;    is temporarily stored for distribution.
 ;*
 ;MSG_ROOT=CLOSED ARRAY REFERENCE
 ;    (Optional) - Closed array reference where messages such as
 ;    errors will be returned.  If not passed, decendents of ^TMP
 ;    will be used.
 ;*
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 I $G(DIFRSA)']"" D ERR(6) G EXIT
 S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA"))
 ;
 I '$D(DIFRFIA) D ERR(2) G EXIT
 N DIFRFRVX,DIFRFILE
 S DIFRFRVX="FRV1",DIFRFILE=0 F  S DIFRFILE=$O(@DIFRSA@(DIFRFRVX,DIFRFILE)) Q:DIFRFILE'>0  D FILE
 G EXIT
 ;
FILE N DIFRTART,DIFRDNSC,DIFRPCE,DIFRSDA,DIFRY,DIFRPRV,DIFRPTF,DIFRPTFR,DIFRPRVL,DIFR2DD,DIFRTARL
 N C,D0,DA,DIC,DIK,F,G,I,R1,R2,R3,X,Y
 S DIFRTART=$NA(@DIFRSA@(DIFRFRVX,DIFRFILE))
 S DIFRTARL=$NA(@DIFRSA@("FRVL",DIFRFILE))
 S DIFRSDA=$$OREF^DILF($NA(@DIFRSA@("DATA",DIFRFILE))),DIFRDNSC=""
 F  S DIFRDNSC=$O(@DIFRTART@(DIFRDNSC)) Q:DIFRDNSC=""  D
 .K R1
 .S R2=DIFRDNSC,C=$P(R2,","),F=1,R1=0
 .F I=1:1 Q:I>C  S G=$P(R2,",",F,I) Q:G=""  I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1(R1)=G,R1=R1+1,C=C+($L(G,",")-1)
 .I R1'>3 S DIFR2DD=DIFRFILE
 .E  D
 ..S R3=""
 ..F I=0:1:R1-3 S R3=R3_R1(I)_","
 ..S DIFR2DD=+$P($G(@(DIFRSDA_R3_"0)")),"^",2)
 ..Q
 .;
 .S DIFRPCE=""
 .F  S DIFRPCE=$O(@DIFRTART@(DIFRDNSC,DIFRPCE)) Q:DIFRPCE'>0  D
 ..S DIFRPRV=$G(@DIFRTART@(DIFRDNSC,DIFRPCE)),DIFRPTF=$G(^(DIFRPCE,"F"))
 ..S DIFRPRVL=$G(@DIFRTARL@(DIFRDNSC)),DIFRPTFR=$P(DIFRPTF,";",2)
 ..I DIFRPRVL="" D ERR(7," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q
 ..I DIFRPTFR="" D ERR(8," ("_DIFRPRVL_"/"_DIFRPRV_")") Q
 ..I DIFRPRV="" D ERR(9," (^"_DIFRPTFR_"/"_DIFRPRVL_")") Q
 ..I '$D(@("^"_DIFRPTFR_"0)")) D ERR(10," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q
 ..S DIC="^"_DIFRPTFR,DIC(0)="X",X=DIFRPRV D ^DIC I +Y'>0 D ERR(11," ("_DIC_"  Entry:"_DIFRPRV_")") S Y=""
 ..S DIFRY=+Y S:DIFRPTF DIFRY=+Y_";"_DIFRPTFR
 ..S $P(@DIFRPRVL,"^",DIFRPCE)=DIFRY
 ..Q
 ;
 S DIK=@DIFRFIA@(DIFRFILE,0),DIK(0)="AB"
 D IXALL^DIK:$O(@(DIK_"0)"))
 ;
 Q
 ;
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q
ERR(X,Y) S X=$P($T(ERR+X),";",5) S:$D(Y) Y(1)=Y Q:'X  D BLD^DIALOG(X,.Y) Q
 ;;FIA Node Is Set To "No Data";1;9509
 ;;FIA Array Does Not Exist;2;9501
 ;;;3;
 ;;Records Do Not Exist;4;9510
 ;;FIA File Number Invalid;5;9502
 ;;Source Array Root Missing;6;9533
 ;;Resolved Value Data Link Missing;7;9534
 ;;Pointed Too File Missing;8;9535
 ;;Pointer Resolved Value Missing;9;9538
 ;;Pointed Too File NOT on Target System;10;9536
 ;;Unable To Find Exact Match And Resolve Pointer;11;9537

DIFROMSS
DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96  18:55
 ;;21.0;VA FileMan;**15**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
SEL(DIFRFILE,DIFRX) ;Extrinsic function to return resolved value for
 ;freetext pointer
 ;FILE,X-VALUE
 N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
 N %,%K,%Y,DA,D0,D1,D2,D3
 S DIC="^DIBT(",DIC(0)="QEMZ",X=DIFRX
 S DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
 D ^DIC
 Q:Y'>0 ""
 Q Y(0,0)
 ;
HELP(DIFRFILE) ;
 N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
 N %,%K,%Y,DA,D0,D1,D2,D3
 S DIC="^DIBT(",DIC(0)="M",DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9",X="??"
 D ^DIC
 Q
 ;
SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL) ;Returns a list of sub-DDs for any DD#
 ;DD#,FLAGS,TARGET ARRAY(by value)
 ;DD/SUB DD NUMBER (required)
 ;FLAGS "W"=Include Word-processing fields (optional)
 ;TARGET ARRAY (required)
 ;DIFRVAL - SET TARGET ARRAY EQUAL TO
 N DIFRSDD,DIFRSSDD,DIFRNW
 S DIFRSDD=0,DIFRNW=$G(DIFRFLG)'["W",DIFRVAL=$G(DIFRVAL)
 F  S DIFRSDD=$O(^DD(DIFRDD,"SB",DIFRSDD)) Q:DIFRSDD'>0  D
 .S DIFRSSDD=0
 .I DIFRNW,$P($G(^DD(DIFRSDD,.01,0)),"^",2)["W" Q
 .S @DIFRTA@(DIFRSDD)=DIFRVAL,DIFRSSDD=$O(^DD(DIFRSDD,"SB",0))
 .I DIFRSSDD D SB(DIFRSDD,$G(DIFRFLG),DIFRTA,DIFRVAL)
 .Q
 Q
 ;
HDR2P(DIFRDD) ;Header Node/2nd piece update
 Q:$G(DIFRDD)'>0 ""
 Q:'$D(^DIC(+DIFRDD,0,"GL")) "" S DIFRDD=$TR(DIFRDD_$P($P(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs")
 N DIFRDDT
 I $D(^DD(+DIFRDD,0,"ID")) S DIFRDD=DIFRDD_"I"
 I $D(^DD(+DIFRDD,0,"SCR")) S DIFRDD=DIFRDD_"s"
 F DIFRDDT="D","P","S","V" I $P(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT S DIFRDD=DIFRDD_DIFRDDT Q
 Q DIFRDD
 ;
EXAM(TA) ;Examine what's in 2nd piece of data Header and put into array sub
 ;TA=Target Array
 Q:$G(TA)']""
 N FN,GR,P2
 S FN=0
 F  S FN=$O(^DIC(FN)) Q:FN'>0  I $D(^DIC(FN,0,"GL")) S GR=^("GL") D
 .Q:'$D(@(GR_"0)"))  S P2=$P(^(0),"^",2),P2=$P(P2,+P2,2)
 .S:P2]"" @TA@(P2)=FN
 .Q
 Q
 ;
VAL(DIFRFILE,DIFRIEN) ;Validate Edit and Print Template's and also Forms
 S DIFRFILE=$G(DIFRFILE),DIFRIEN=$G(DIFRIEN)
 Q:DIFRIEN'>0 0
 N ROOT,PIECE,FILE
 D
 .N X
 .S X=DIFRFILE
 .I X=.4!(X=.402)!(X=.403)!(X=.404) Q
 .S DIFRFILE=0
 .Q
 Q:DIFRFILE'>0 0
 S ROOT="^"_$P($P(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^")
 S PIECE=$P($P(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^")
 Q:'$D(@ROOT@(DIFRIEN,0)) 0
 S FILE=$P(^(0),"^",PIECE)
 I DIFRFILE=.404&('FILE) Q 1
 Q:FILE'>0 0
 I DIFRFILE=.403 N BLOCK D  Q:'BLOCK 0
 .N PAGE,BLOCKP
 .S PAGE=0,BLOCK=1
 .F  S PAGE=$O(@ROOT@(DIFRIEN,40,PAGE)) Q:PAGE'>0  S BLOCKP=$P($G(^(PAGE,0)),"^",2) S:BLOCKP BLOCK=$$VAL(.404,BLOCKP) Q:'BLOCK  D  Q:'BLOCK
 ..N M40
 ..S M40=0
 ..F  S M40=$O(@ROOT@(DIFRIEN,40,PAGE,40,M40)) Q:M40'>0  S BLOCK=$$VAL(.404,M40) Q:'BLOCK
 ..Q
 .Q
 I DIFRFILE=.4,$P(@ROOT@(DIFRIEN,0),"^",8) Q 0
 Q $D(^DD(FILE,0))#2

DIFROMSU
DIFROMSU ;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY ;6/2/96  18:48
 ;;21.0;VA FileMan;**10,15**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
FIA(DIFRFILE,DIFRFLG,DIFRPFL,DIFRTAR,DIFR222,DIFR223,DIFRDSCR,DIFRVER,DIFRMSGR) ;
 ;FILE,FLAGS,PARTIAL_FILE_LIST,TARGET_ARRAY_ROOT,ANSWERS,DD_SCREEN,DATA_SCREEN,VERSION,MSG_ARRAY
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1
 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
 N DIFRFD,DIFRFE,DIFRX,FIELD,FIELDNR,DIFRTA,DIFRP,DIFR00
 S DIFRTA=$NA(@DIFRTAR@("FIA"))
 I $G(DIFRFILE)'>0 D BLD^DIALOG(9542) Q
 I '$D(^DIC(DIFRFILE)) D BLD^DIALOG(9539,DIFRFILE) Q
 I $P($G(DIFR222),"^",3)'="p" G F
 I $G(DIFRPFL)']"" G F
 I $D(@DIFRPFL)'>9 G F
 G F:$O(@DIFRPFL@(0))'>0
 N DIFRDDC,DIFRFLDC,DIFRTMP
 K ^TMP("FIA",$J)
 S DIFRDDC=0,DIFRTMP=$NA(^TMP("FIA",$J))
 M @DIFRTMP=@DIFRPFL
 F  S DIFRDDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC)) Q:DIFRDDC'>0  D
 .I '$D(^DD(DIFRDDC)) K @DIFRTMP@(DIFRFILE,DIFRDDC) D BLD^DIALOG(9540,DIFRDDC) Q
 .I '$O(@DIFRTMP@(DIFRFILE,DIFRDDC,0)) D  Q
 ..Q:@DIFRTMP@(DIFRFILE,DIFRDDC)="SUB"
 ..D SB^DIFROMSS(DIFRDDC,"W",$NA(@DIFRTMP@(DIFRFILE)),"SUB")
 ..Q
 .S DIFRFLDC=0
 .F  S DIFRFLDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)) Q:DIFRFLDC'>0  D
 ..I '$D(^DD(DIFRDDC,DIFRFLDC,0)) K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC) D  Q
 ...N DIFRX S DIFRX(1)=DIFRFLDC,DIFRX(2)=DIFRDDC
 ...D BLD^DIALOG(9541,.DIFRX)
 ...Q
 ..I $P(^DD(DIFRDDC,DIFRFLDC,0),"^",2) S DIFRX=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D
 ...I DIFRX["W" S @DIFRTMP@(DIFRFILE,+$P(^DD(DIFRDDC,DIFRFLDC,0),"^",2))=0 Q
 ...K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)
 ...Q
 ..Q
 .Q
 ;
 M @DIFRTA@(DIFRFILE)=@DIFRTMP@(DIFRFILE)
 K @DIFRTMP
 ;
 I $D(@DIFRTA@(DIFRFILE,DIFRFILE))=1 G F
 S @DIFRTA@(DIFRFILE,DIFRFILE)=1,DIFRFE=DIFRFILE
 ;F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  S:$P(^DD(DIFRFE,.01,0),"^",2)'["W" @DIFRTA@(DIFRFILE,DIFRFE,.01)=0
 F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
 .S @DIFRTA@(DIFRFILE,DIFRFE)=$D(@DIFRTA@(DIFRFILE,DIFRFE))>9
 .N DIFRX,DIFRY
 .S DIFRY=$$UP^DIQGU(DIFRFE,.DIFRX)
 .Q:'$D(DIFRX)
 .;K DIFRX($O(DIFRX(""))) <<REMOVED IN PATCH 10>>
 .M @DIFRTAR@("UP",DIFRFILE,DIFRFE)=DIFRX
 .Q
 S DIFRFE=DIFRFILE
 F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D:'^(DIFRFE)!($D(@DIFRTA@(DIFRFILE,DIFRFE,.01)))
 .Q:'$D(^DD(DIFRFE,0,"UP"))
 .N DIFRUP,DIFRFLD
 .S DIFRUP=^DD(DIFRFE,0,"UP"),DIFRFLD=$O(^DD(DIFRUP,"SB",DIFRFE,0))
 .Q:$G(@DIFRTA@(DIFRFILE,DIFRUP))=0!($D(@DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)))
 .S @DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)=""
 .Q:$D(@DIFRTA@(DIFRFILE,DIFRUP))#2
 .S @DIFRTA@(DIFRFILE,DIFRUP)=1
 .Q
 ;
 G G
F S @DIFRTA@(DIFRFILE,DIFRFILE)=0,DIFRFE=0
 S:$P(DIFR222,"^",3)'="f" $P(DIFR222,"^",3)="f"
E F  S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0  D
 .S DIFRFD=0
 .F  S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0  S @DIFRTA@(DIFRFILE,DIFRFD)=0
 .Q
G S @DIFRTA@(DIFRFILE)=$P(^DIC(DIFRFILE,0),"^")
 S (DIFR00,@DIFRTA@(DIFRFILE,0))=^DIC(DIFRFILE,0,"GL")
 S @DIFRTA@(DIFRFILE,0,0)=$P(@(DIFR00_"0)"),"^",2)
 S @DIFRTA@(DIFRFILE,0,1)=$G(DIFR222)
 S @DIFRTA@(DIFRFILE,0,10)=$G(DIFR223)
 S @DIFRTA@(DIFRFILE,0,11)=$G(DIFRDSCR)
 S @DIFRTA@(DIFRFILE,0,"RLRO")=$$ROOT($P(DIFR222,"^",6))
 I $G(DIFRVER)]"" S @DIFRTA@(DIFRFILE,0,"VR")=DIFRVER
FE I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
 Q
 ;
ERR501(DIFRFILE,DIFRFLD) ;  501 Errors
 N DIFRERRX
 S DIFRERRX("FILE")=DIFRFILE,DIFRERRX(1)=DIFRFLD
 D BLD^DIALOG(501,.DIFRERRX)
 Q
ROOT(IEN) ;Create root from DIBT(ien
 ;
 I $G(IEN)>0,$D(^DIBT(IEN,1))>9 Q "^DIBT("_IEN_",1)"
 I $G(IEN)]"" S IEN=$O(^DIBT("F"_DIFRFILE,IEN,"")) Q:IEN>0 $$ROOT(IEN)
 Q ""

DIFROMSV
DIFROMSV ;SFISC/DCL-DIFROM SERVER UTILITY,PKG REV DATA;08:40 AM  6 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
PRD(DIFRFILE,DIFRPRD) ;Package Revision Data for File
EN ;FILE,DATA
 ;Used to install Package Data from Post-Installation Routine
 Q:$G(DIFRFILE)'>1
 Q:'$D(^DD(DIFRFILE))
 S ^DD(DIFRFILE,0,"VRRV")=$G(DIFRPRD)
 Q

DIG
DIG ;SFISC/GFT-SCATTERGRAM ;2/24/93  11:01 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I '$D(^DOSV(0,IO(0),2)) W !,"NO SUB-SUB TOTALS WERE RUN" Q
 K ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS G ENDK:POP,QUE:$D(IO("Q"))
DQ S C(1)=^DOSV(0,IO,"BY",1),C(2)=^(2),X=$O(^DOSV(0,IO(0),2,"")),(DXMIN,DXMAX)=X,(DYMIN,DYMAX)=$O(^(X,"")),X=""
 I $E(IOST)="C" S DIFF=1
 F C=1,2 S C(C,0)=$S($D(^DD(+C(C),+$P(C(C),U,2),0)):$P(^(0),U,2),1:$P(C(C),U,7))
 F C=0:0 S X=$O(^DOSV(0,IO(0),2,X)) Q:X=""  S:X>DXMAX DXMAX=X S Y=$O(^(X,"")),DY=Y S:Y<DYMIN DYMIN=Y D A S:DYMAX<DY DYMAX=DY
 I DXMAX-DXMIN*(DYMAX-DYMIN)=0 W $C(7),!,"NO RANGE OF VARIABLES" G ENDK
 S H=DYMAX,L=DYMIN,DYS=IOSL-9,N=DYS/6,C=2 D S S DYMIN=B,DYSC=I/6,DYMAX=T,DYI=X
DYI I T-B/DYI*6'>DYS S DYI=DYI\2 G DYI
 S H=DXMAX,L=DXMIN,DXS=IOM-28,N=DXS/6,C=1 D S S DXMIN=B,DXSC=I/6,DXI=X,DXMAX=T,T=X*DXS/(T-B),H=-1
LOOP K ^UTILITY($J) S H=$O(^DOSV(0,IO(0),"F",H)) I H S X=^(H) U IO W:$D(DIFF)&($Y) @IOF S DIFF=1 W ?22,$O(^DD(+X,0,"NM",0))," ",$P(X,U,$P(X,U,2)'=.01*3)," COUNT   " S (B,DX,DY)="" D I2 G LOOP:X'=U
END W:$E(IOST)'="C"&($Y) @IOF K:$D(ZTSK) ^DOSV(0,IO) D CLOSE^DIO4
ENDK K %H,%T,%Y,%D,B,I,L,H,T,C,X,Y,POP,IOP,DX,DY,DXS,DYS,DXSC,DYSC,DXMIN,DYMIN,DXMAX,DYMAX,DXI,N,DYI,DIFF Q
 ;
I2 S (DX,X)=$O(^DOSV(0,IO(0),2,DX)) I X="" W "(TOTAL = "_B_")",! G O
 I C(1,0)["D" D H^%DTC S X=%H
 S X=$J(X-DXMIN/DXSC,0,0)
I3 S (Y,DY)=$O(^DOSV(0,IO(0),2,DX,DY)) G I2:Y="" I C(2,0)["D" S C=X,X=Y D H^%DTC S Y=%H,X=C
 G I3:'$D(^(DY,H,"N")) S C=^("N"),Y=$J(Y-DYMIN/DYSC,0,0),B=B+C,^(X)=C+$S($D(^UTILITY($J,Y,X)):^(X),1:0) G I3
 ;
A F C=0:0 S Y=$O(^(DY)) Q:Y=""  S DY=Y
 Q
 ;
O S X=0 D X W !?12,"." D P K Y S L=0 F B=DYMIN:DYI:DYMAX S C=2,Y=B D Y S Y($J(L,0,0))=Y,L=DYI*DYS/(DYMAX-DYMIN)+L
 W ".",! F Y=DYS:-1:0 D LINE W !
 W ?13 D P W ! S X=DXI D X W !?22,"X-AXIS: ",$P(C(1),U,3),"    Y-AXIS: ",$P(C(2),U,3) I IOST?1"C".E W $C(7) R X:DTIME S:'$T X=U
 Q
 ;
P S L=-1,X=0
PP I L<X W "+" S L=L+T
 E  W "-"
 S X=X+1 G PP:X'>DXS Q
 ;
X F B=DXMIN+X:DXI*2:DXMAX S Y=B,C=1 D Y W ?B-DXMIN\DXSC-($L(Y)\2)+13,Y
 Q
Y S C=C(C,0) I C["D" S %H=Y D 7^%DTC S Y=X
 G S^DIQ
 ;
LINE I $D(Y(Y)) W ?12-$L(Y(Y)),Y(Y),"+"
 E  W ?12,"|"
 S X="" F  S X=$O(^UTILITY($J,Y,X)) Q:X=""  S I=^(X) W ?X+13,$S(I>9:"*",I:I,1:"")
 W ?DXS+14 I  W "+",Y(Y) Q
 W "|" Q
 ;
S I C(C,0)["D" F B="H","L" S X=@B D H^%DTC S @B=%H
 S B=H-L,X=1 I B>1 F C=1:1 S X=X*10 Q:B'>X
 E  S I=1 Q:'B  F C=0:-1 Q:X/10'>B  S X=X/10
 S B=L-X\X*X F I=B:X/10 Q:I'<L  S B=I
 S T=H+X\X*X F I=T:-X/10 Q:I'>H  S T=I
I S I=T-B/X*10 I I>N S X=X*2 G I
 S X=X/10,I=T-B/N
 Q
QUE ;
 S ZTSAVE("^DOSV(0,$I,")=""
 S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIG"
 D ^%ZTLOAD K ZTSK G END

DIH
DIH ;SFISC/GFT-HISTOGRAM ;1/17/91  1:43 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $O(^DOSV(0,IO(0),0))'>0 W !,$C(7),"NO SUB-COUNTS WERE RUN" Q
 K ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS G ENDK:POP,QUE:$D(IO("Q"))
DQ S J=$I,DN="=$O(^DOSV(0,J," F X=0:1 Q:'$D(^DOSV(0,J,"BY",X+1))
 G END:'X S A=^(1),DD=$P(A,U,3) I $D(^DD(+A,+$P(A,U,2),0)) S DD=^(0)
 S T=$P(DD,U,2),DP=$P(DD,U,3),DF=$S(T["S":1,T["P":2,T["D"!($P(A,U,7)["D"):3,1:0)
 S DMX=DN_X,DX="",F=X
F S DMX=DMX_",D"_F,DX=DX_"S D"_F_"="""" F X=X:0 S D"_F_DMX_")) Q:D"_F_"=""""  "_$P("S X=X+1,DS(X)=0,DD(X)=0,DV(X)=D"_X_" ",U,F=X),F=F-1 G F:F
 S DX=DX_"S:$D(^(D1,F,""N"")) DD(X)=DD(X)+^(""N"") S:$D(^(""S"")) DS(X)=DS(X)+^(""S"")"
 I $E(IOST)="C" S DIFF=1
 S F=-1,C="*",DIHIOM=IOM-23,DIHIOSL=IOSL-8 U IO W:$D(DIFF)&($Y) @IOF S DIFF=1
I S @("F"_DN_"""F"",F))") I 'F G END
 S X=0,T=^(F),DS=1 X DX S DIH=X
 D MAX G I
 ;
MAX S DMX=0 F N=1:1:DIH S:DD(N)>DMX DMX=DD(N) D LBL:DS=1&DF S DV(N)=$E(DV(N),1,14)
 S X=1 F S=1:1 S X=X*2 Q:DMX'>X
 S D1=DMX+X\X*X F S=D1:-X/2 Q:S'>DMX  S D1=S
 S D2=DIHIOM*X/D1
XX S X=X\2,D2=D2\2 I X>4,$L(X)+7<D2 G XX
 I DMX S S=D1/DIHIOM,D1=D2 F X=1:1:DIH D HD:X=1!'(X-1#DIHIOSL),LN,TR:X=N!'(X#DIHIOSL) I Y=U Q
SUM Q:$P(T,U,4)["D"!(Y=U)  I DS=1 S DS=2 F N=1:1 G:N>DIH MAX S S=DD(N),DD(N)=DS(N),DS(N)=S
MEAN I DS=2 S DS=3 F N=1:1 S DD(N)=$S(DS(N):DD(N)/DS(N),1:0) G MAX:N=DIH
 Q
 ;
END W:($E(IOST)'="C")&($Y) @IOF K:$D(ZTSK) ^DOSV(0,IO) D CLOSE^DIO4
ENDK K ZTSK,DIH,S,A,C,DD,DS,D1,D2,DN,T,DP,F,N,J,POP,DF,X,Y,DX,DMX,DV,DIHIOM,DIHIOSL,DIFF Q
 ;
LBL I DF=1 S D1=$F(DP,DV(N)_":") S:D1 DV(N)=$P($E(DP,D1,999),";",1) Q
 I DF=2 S DV(N)=$P(@(U_DP_DV(N)_",0)"),U,1) Q
 S D1=$E(DV(N),6,7),D2=$E(DV(N),4,5),DV(N)=$P(+D2_"-",U,D2>0)_$P(+D1_"-",U,D1>0)_(DV(N)\10000+$S(D2:-200,1:1700)) Q
 ;
HD U IO W:$Y+N+1>DIHIOSL @IOF W !!?27,$P("COUNT^SUM^MEAN",U,DS),", " I $D(^DD(+T,0)) S Y=+$P(T,U,2) I Y>.01,$D(^(Y,0)) W $P(^(0),U,1),", "
 W "BY ",$P(DD,U,1),!! Q
LN W ?15-$L(DV(X))-1,DV(X)," |" F Y=1:1:DD(X)/S W C
 W ! Q
TR W ?15 F Y=0:1:DIHIOM W $E("-+",Y#D1=0+1)
 W ! F Y=1:1:DIHIOM I Y#D1=0 S D2=$J(Y*S,0,0) W ?Y+15-($L(D2)\2),D2
 I IOST?1"C".E W $C(7) R Y:DTIME
 Q
QUE ;
 S ZTSAVE("^DOSV(0,$I,")=""
 S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIH"
 D ^%ZTLOAD K ZTSK G END
 ;

DII
DII ;SFISC/GFT,XAK,TKW-OPTION RDR, INQUIRY ;9/9/94  14:55
V ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W !!,"VA FileMan "_$P($T(V),";",3),!
NOKL D DT^DICRW,OS S DIK="^DOPT(""DII""," G F:$D(^DOPT("DII",9)) S ^(0)="OPTION^1.01^" F I=1:1 S X=$E($T(F+I),4,99) Q:X=""  S ^DOPT("DII",I,0)=X
 D IXALL^DIK
F S DIC=DIK,DIC(0)="AEQZ" D ^DIC K DIC,DIK G Q:Y<0 S X=$P(Y(0),U,2,99) K Y D @X W !!! D Q G NOKL
 ;;ENTER OR EDIT FILE ENTRIES^^DIB
 ;;PRINT FILE ENTRIES^^DIP
 ;;SEARCH FILE ENTRIES^^DIS
 ;;MODIFY FILE ATTRIBUTES^^DICATT
 ;;INQUIRE TO FILE ENTRIES^INQ^DII
 ;;UTILITY FUNCTIONS^^DIU
 ;;OTHER OPTIONS^^DII1
 ;;DATA DICTIONARY UTILITIES^^DDU
 ;;TRANSFER ENTRIES^^DIT
 ;
Q D Q^DIB,Q^DICATT2,Q^DIARB
 K DRK,DIL,DIS,DK,DIACD,DIQ,DX,DQI,DISYS,DHIT,%X,%Y,%,DXS,Q,DIAR
 K A0,D9,DNP,DCC,DIJ,DP,DM,DQ,DICATT,DIFLD,D0,DIEL,DL,DC,DU,DIP
 K DH,DIYS,DINS,DIPT,DHD,DCL,DPP,DPQ,DALL,DIRUT,DIROUT,DUOUT,DTOUT
 Q
INQ ;
 W !! D ^DICRW Q:'$D(DIC)  S DI=DIC,DPP(1)=+Y_"^^^@",DK=+Y I $D(DICS) S DICSS=DICS
B K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS S DIC=DI,DIC(0)="AEQM",DIK=0
R D ^DIC I Y>0 S DIK=DIK+1,^UTILITY(U,$J,DIK,+Y)="",DIC("A")="ANOTHER ONE: " G R
S G Q^DIP:'DIK!(X=U) G:DIK'>3 O
 D  K DIRUT,DIROUT
 . N DIK,DI,DICSS,DX D S2^DIBT1 Q
 G:$D(DTOUT)!($D(DUOUT)) Q^DIP G:X="" O G:Y<0 S
 F X=1:1:DIK S ^DIBT(+Y,1,+$O(^UTILITY(U,$J,X,0)))=""
 S ^DIBT(+Y,"QR")=DT_U_DIK
O K DIC G Q^DIP:$D(DTOUT) S DIC=DI,%=1
 W !,"STANDARD CAPTIONED OUTPUT" D YN^DICN G Q^DIP:%<0
 I '% W !?5,"Answer 'N' to create a formatted display as in the Print Option." G O
 I %=2 S L=1,Q="""",DPP=1,DPP(1,"IX")="^UTILITY(U,$J,"_DI_"^2" S:$D(DICSS) DICS=DICSS G N^DIP1
 D C G:$D(DIRUT) Q
AD I $D(^DIA(DK)) S %=2 W !,"DISPLAY AUDIT TRAIL" D YN^DICN G Q:%<0 S:%=1 DIQ(0)=DIQ(0)_"A" I '% W !?5,"Answer 'Y' to display the audit trail for each Entry." G AD
 S IOP="HOME" D ^%ZIS I $D(DICSS) S DICS=DICSS
 S S=1 F DIK=1:1:DIK S DA=+$O(^UTILITY(U,$J,DIK,0)),DIC=DI,E="N<0",N=-1,DD=DK W ! X:DIK>1 DX(0) Q:'S  D GUY^DIQ Q:'S  I DIQ(0)["A",$D(^DIA(DK,"B",DA)) D AUD
 W !! Q:$D(DTOUT)  G B
 ;
P G Q^DI
 ;
OS I $D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2) Q:DISYS>0
 S DISYS=$S($D(^DD("OS"))#2:^("OS"),1:100)
 Q
AUD S DIACD=DIQ(0),DIQ(0)="C",DIQ=DA
 F DA=0:0 S DA=$O(^DIA(DK,"B",DIQ,DA)) Q:DA'>0  S DIC="^DIA("_DK_",",E="N<0",N=-1,DD=1.1,DIA=DK D GUY^DIQ Q:'S  W !
 S DIQ(0)=DIACD Q
 ;
C N DIR,I,L,Y,X,DITXT D BLD^DIALOG(7004,"","","DIR") S DITXT="" D  S DITXT=DITXT_DIR
 . F I=1:1 Q:$G(DIR(I))=""  S DITXT=DITXT_DIR(I)
 . Q
 K DIR S DIR(0)="SMB^"_DITXT,DIR("B")=$P($P(DITXT,":",2)," ",1),DIR("A")=$$EZBLD^DIALOG(8002)
 D ^DIR Q:$D(DIRUT)
 F I=1:1 S X=$P($P(DITXT,";",I),":") Q:X=""  I X=Y S DIQ(0)=$S(I=2:"C",I=3:"R",I=4:"CR",1:"") Q
 S:X'=Y DIRUT=1 Q
 ;7004  N:NO;Y:YES;R:Record Number;B:BOTH Computed Fields and Record No.
 ;8002  Include COMPUTED fields

DII1
DII1 ;SFISC/XAK-OTHER OPTIONS ;5/19/94  2:05 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DII1"","
 G OPT:$D(^DOPT("DII1",8)) S ^(0)="OTHER OPTION^1.01" K ^("B")
 F X=1:1:8 S ^DOPT("DII1",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK
OPT ;
 S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
 ;
EN ;
 D @DI W !!
Q K %,DIC,DIK,DI,DA,I,J,X,Y Q
 ;
1 ;;FILEGRAMS
 G ^DIFGO
 ;
2 ;;ARCHIVING
 G NOKL^DIAR
 ;
3 ;;AUDITING
 G ^DIAU
 ;
4 ;;SCREENMAN
 G ^DDSOPT
 ;
5 ;;STATISTICS
 G ^DIX
 ;
6 ;;EXTRACT DATA TO FILEMAN FILE
 G ^DIAX
 ;
7 ;;DATA EXPORT TO FOREIGN FORMAT
 G NOKL^DDXP
8 ;;BROWSER
 G ^DDBR

DIINI001
DIINI001 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"KEY",24,0)
 ;;=DIEXTRACT
 ;;^UTILITY(U,$J,"KEY",24,1,0)
 ;;=^^3^3^2930106^
 ;;^UTILITY(U,$J,"KEY",24,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"KEY",24,1,2,0)
 ;;=This key is needed to access the menu for extracting data to a VA FileMan
 ;;^UTILITY(U,$J,"KEY",24,1,3,0)
 ;;=file.
 ;;^UTILITY(U,$J,"KEY",25,0)
 ;;=DDXP-DEFINE
 ;;^UTILITY(U,$J,"KEY",25,1,0)
 ;;=^^3^3^2930108^^
 ;;^UTILITY(U,$J,"KEY",25,1,1,0)
 ;;=Holders of this key can use the Define Foreign File Format option.  That
 ;;^UTILITY(U,$J,"KEY",25,1,2,0)
 ;;=option defines foreign formats, modifies existing formats that have not
 ;;^UTILITY(U,$J,"KEY",25,1,3,0)
 ;;=been used to create an export template, and clones formats.
 ;;^UTILITY(U,$J,"OPT",9,0)
 ;;=DIEDIT^Enter or Edit File Entries^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",9,1,0)
 ;;=^^2^2^2890316^^^^
 ;;^UTILITY(U,$J,"OPT",9,1,1,0)
 ;;=This option is used to enter new entries in a file or edit existing ones.
 ;;^UTILITY(U,$J,"OPT",9,1,2,0)
 ;;=You specify the file and fields within the file to edit.
 ;;^UTILITY(U,$J,"OPT",9,20)
 ;;=D ^DIB
 ;;^UTILITY(U,$J,"OPT",9,99)
 ;;=52905,54998
 ;;^UTILITY(U,$J,"OPT",9,"U")
 ;;=ENTER OR EDIT FILE ENTRIES
 ;;^UTILITY(U,$J,"OPT",10,0)
 ;;=DIPRINT^Print File Entries^^A^^^^^^^y^^n^1^^
 ;;^UTILITY(U,$J,"OPT",10,1,0)
 ;;=^^3^3^2910625^^^^
 ;;^UTILITY(U,$J,"OPT",10,1,1,0)
 ;;=This option is used to print a report from a file, where a number of
 ;;^UTILITY(U,$J,"OPT",10,1,2,0)
 ;;=entries are to be listed in a columnar format.  Each column can be
 ;;^UTILITY(U,$J,"OPT",10,1,3,0)
 ;;=individually controlled for format, tabulation, justification, etc.
 ;;^UTILITY(U,$J,"OPT",10,20)
 ;;=D ^DIP
 ;;^UTILITY(U,$J,"OPT",10,99.1)
 ;;=55061,47656
 ;;^UTILITY(U,$J,"OPT",10,"U")
 ;;=PRINT FILE ENTRIES
 ;;^UTILITY(U,$J,"OPT",11,0)
 ;;=DISEARCH^Search File Entries^^A^^^^^^^y^^n^1^^
 ;;^UTILITY(U,$J,"OPT",11,1,0)
 ;;=^^3^3^2930728^^^^
 ;;^UTILITY(U,$J,"OPT",11,1,1,0)
 ;;=This option is used to print a report in which entries are to be selected
 ;;^UTILITY(U,$J,"OPT",11,1,2,0)
 ;;=according to a pre-determined set of criteria.  After the search criteria 
 ;;^UTILITY(U,$J,"OPT",11,1,3,0)
 ;;=is met, a standard report will be generated.
 ;;^UTILITY(U,$J,"OPT",11,20)
 ;;=D ^DIS
 ;;^UTILITY(U,$J,"OPT",11,"U")
 ;;=SEARCH FILE ENTRIES
 ;;^UTILITY(U,$J,"OPT",12,0)
 ;;=DIMODIFY^Modify File Attributes^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",12,1,0)
 ;;=^^2^2^2890316^^^
 ;;^UTILITY(U,$J,"OPT",12,1,1,0)
 ;;=This option is used to modify the structure of a file or the 
 ;;^UTILITY(U,$J,"OPT",12,1,2,0)
 ;;=characteristics of its fields.
 ;;^UTILITY(U,$J,"OPT",12,20)
 ;;=D ^DICATT
 ;;^UTILITY(U,$J,"OPT",12,"U")
 ;;=MODIFY FILE ATTRIBUTES
 ;;^UTILITY(U,$J,"OPT",13,0)
 ;;=DIINQUIRE^Inquire to File Entries^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",13,1,0)
 ;;=3^^4^4^2890316^^
 ;;^UTILITY(U,$J,"OPT",13,1,1,0)
 ;;=This option is used to display all the data for a group of specified
 ;;^UTILITY(U,$J,"OPT",13,1,2,0)
 ;;=entries in a file.  This is useful for a quick look at a small number
 ;;^UTILITY(U,$J,"OPT",13,1,3,0)
 ;;=of entries.  Use the Print File Entries option for larger numbers
 ;;^UTILITY(U,$J,"OPT",13,1,4,0)
 ;;=of entries.
 ;;^UTILITY(U,$J,"OPT",13,20)
 ;;=D INQ^DII
 ;;^UTILITY(U,$J,"OPT",13,"U")
 ;;=INQUIRE TO FILE ENTRIES
 ;;^UTILITY(U,$J,"OPT",14,0)
 ;;=DIUTILITY^Utility Functions^^M^^^^^^^^^n^^
 ;;^UTILITY(U,$J,"OPT",14,1,0)
 ;;=^^2^2^2901205^^^^
 ;;^UTILITY(U,$J,"OPT",14,1,1,0)
 ;;=This option is a menu of VA FileMan utilities used to maintain the more
 ;;^UTILITY(U,$J,"OPT",14,1,2,0)
 ;;=technical aspects of files.
 ;;^UTILITY(U,$J,"OPT",14,10,0)
 ;;=^19.01IP^10^10
 ;;^UTILITY(U,$J,"OPT",14,10,1,0)
 ;;=163^^6
 ;;^UTILITY(U,$J,"OPT",14,10,1,"^")
 ;;=DIEDFILE
 ;;^UTILITY(U,$J,"OPT",14,10,2,0)
 ;;=159^^2
 ;;^UTILITY(U,$J,"OPT",14,10,2,"^")
 ;;=DIXREF
 ;;^UTILITY(U,$J,"OPT",14,10,3,0)
 ;;=162^^5
 ;;^UTILITY(U,$J,"OPT",14,10,3,"^")
 ;;=DIITRAN
 ;;^UTILITY(U,$J,"OPT",14,10,4,0)
 ;;=160^^3
 ;;^UTILITY(U,$J,"OPT",14,10,4,"^")
 ;;=DIIDENT
 ;;^UTILITY(U,$J,"OPT",14,10,5,0)
 ;;=161^^4
 ;;^UTILITY(U,$J,"OPT",14,10,5,"^")
 ;;=DIRDEX
 ;;^UTILITY(U,$J,"OPT",14,10,6,0)
 ;;=164^^7
 ;;^UTILITY(U,$J,"OPT",14,10,6,"^")
 ;;=DIOTRAN
 ;;^UTILITY(U,$J,"OPT",14,10,7,0)
 ;;=165^^8
 ;;^UTILITY(U,$J,"OPT",14,10,7,"^")
 ;;=DITEMP
 ;;^UTILITY(U,$J,"OPT",14,10,8,0)
 ;;=166^^9
 ;;^UTILITY(U,$J,"OPT",14,10,8,"^")
 ;;=DIUNEDIT

DIINI002
DIINI002 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",14,10,9,0)
 ;;=158^^1
 ;;^UTILITY(U,$J,"OPT",14,10,9,"^")
 ;;=DIVERIFY
 ;;^UTILITY(U,$J,"OPT",14,10,10,0)
 ;;=336^^10
 ;;^UTILITY(U,$J,"OPT",14,10,10,"^")
 ;;=DIFIELD CHECK
 ;;^UTILITY(U,$J,"OPT",14,20)
 ;;=
 ;;^UTILITY(U,$J,"OPT",14,99)
 ;;=55633,47369
 ;;^UTILITY(U,$J,"OPT",14,"U")
 ;;=UTILITY FUNCTIONS
 ;;^UTILITY(U,$J,"OPT",15,0)
 ;;=DISTATISTICS^Statistics^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",15,1,0)
 ;;=^^3^3^2890316^^^
 ;;^UTILITY(U,$J,"OPT",15,1,1,0)
 ;;=After generating output from the Print File Entries or Search File Entries
 ;;^UTILITY(U,$J,"OPT",15,1,2,0)
 ;;=options, call upon the Statistics option to produce your choice of 
 ;;^UTILITY(U,$J,"OPT",15,1,3,0)
 ;;=seven types of statistical tallies.
 ;;^UTILITY(U,$J,"OPT",15,20)
 ;;=D ^DIX
 ;;^UTILITY(U,$J,"OPT",15,"U")
 ;;=STATISTICS
 ;;^UTILITY(U,$J,"OPT",16,0)
 ;;=DILIST^List File Attributes^^A^^^^^^^y^^n^1^^
 ;;^UTILITY(U,$J,"OPT",16,1,0)
 ;;=^^3^3^2890316^^^^
 ;;^UTILITY(U,$J,"OPT",16,1,1,0)
 ;;=This option is used to print data dictionary listings for a given file.
 ;;^UTILITY(U,$J,"OPT",16,1,2,0)
 ;;=This listing is useful for programmers, analysts, and others interested
 ;;^UTILITY(U,$J,"OPT",16,1,3,0)
 ;;=in data base structures.
 ;;^UTILITY(U,$J,"OPT",16,20)
 ;;=D ^DID
 ;;^UTILITY(U,$J,"OPT",16,99.1)
 ;;=54447,33461
 ;;^UTILITY(U,$J,"OPT",16,"U")
 ;;=LIST FILE ATTRIBUTES
 ;;^UTILITY(U,$J,"OPT",17,0)
 ;;=DITRANSFER^Transfer Entries^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",17,1,0)
 ;;=^^2^2^2890316^^^^
 ;;^UTILITY(U,$J,"OPT",17,1,1,0)
 ;;=This option is used to transfer entries from one file to another or to
 ;;^UTILITY(U,$J,"OPT",17,1,2,0)
 ;;=merge data from one entry to another in the same file.
 ;;^UTILITY(U,$J,"OPT",17,20)
 ;;=D ^DIT
 ;;^UTILITY(U,$J,"OPT",17,"U")
 ;;=TRANSFER ENTRIES
 ;;^UTILITY(U,$J,"OPT",18,0)
 ;;=DIUSER^VA FileMan^^M^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",18,1,0)
 ;;=^^2^2^2910205^^^^
 ;;^UTILITY(U,$J,"OPT",18,1,1,0)
 ;;=This option branches to the VA FileMan main menu, which allows you
 ;;^UTILITY(U,$J,"OPT",18,1,2,0)
 ;;=to enter, edit, report, inquire, and maintain data dictionaries.
 ;;^UTILITY(U,$J,"OPT",18,10,0)
 ;;=^19.01IP^11^9
 ;;^UTILITY(U,$J,"OPT",18,10,1,0)
 ;;=9^^1
 ;;^UTILITY(U,$J,"OPT",18,10,1,"^")
 ;;=DIEDIT
 ;;^UTILITY(U,$J,"OPT",18,10,2,0)
 ;;=13^^5
 ;;^UTILITY(U,$J,"OPT",18,10,2,"^")
 ;;=DIINQUIRE
 ;;^UTILITY(U,$J,"OPT",18,10,4,0)
 ;;=12^^4
 ;;^UTILITY(U,$J,"OPT",18,10,4,"^")
 ;;=DIMODIFY
 ;;^UTILITY(U,$J,"OPT",18,10,5,0)
 ;;=10^^2
 ;;^UTILITY(U,$J,"OPT",18,10,5,"^")
 ;;=DIPRINT
 ;;^UTILITY(U,$J,"OPT",18,10,6,0)
 ;;=11^^3
 ;;^UTILITY(U,$J,"OPT",18,10,6,"^")
 ;;=DISEARCH
 ;;^UTILITY(U,$J,"OPT",18,10,8,0)
 ;;=17^^9
 ;;^UTILITY(U,$J,"OPT",18,10,8,"^")
 ;;=DITRANSFER
 ;;^UTILITY(U,$J,"OPT",18,10,9,0)
 ;;=14^^6
 ;;^UTILITY(U,$J,"OPT",18,10,9,"^")
 ;;=DIUTILITY
 ;;^UTILITY(U,$J,"OPT",18,10,10,0)
 ;;=292^^10
 ;;^UTILITY(U,$J,"OPT",18,10,10,"^")
 ;;=DIOTHER
 ;;^UTILITY(U,$J,"OPT",18,10,11,0)
 ;;=349^^8
 ;;^UTILITY(U,$J,"OPT",18,10,11,"^")
 ;;=DI DDU
 ;;^UTILITY(U,$J,"OPT",18,20)
 ;;=W !!?10,"VA FileMan Version "_^DD("VERSION")
 ;;^UTILITY(U,$J,"OPT",18,99)
 ;;=55633,47363
 ;;^UTILITY(U,$J,"OPT",18,99.1)
 ;;=53890,48786
 ;;^UTILITY(U,$J,"OPT",18,1613)
 ;;=
 ;;^UTILITY(U,$J,"OPT",18,"U")
 ;;=VA FILEMAN
 ;;^UTILITY(U,$J,"OPT",104,0)
 ;;=DI DDMAP^Map Pointer Relations^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",104,1,0)
 ;;=^^3^3^2910706^
 ;;^UTILITY(U,$J,"OPT",104,1,1,0)
 ;;=This option prints a map of the pointer relations between a group of
 ;;^UTILITY(U,$J,"OPT",104,1,2,0)
 ;;=files. The file selection is from the package file or entered
 ;;^UTILITY(U,$J,"OPT",104,1,3,0)
 ;;=individually.
 ;;^UTILITY(U,$J,"OPT",104,25)
 ;;=DDMAP
 ;;^UTILITY(U,$J,"OPT",104,136)
 ;;=
 ;;^UTILITY(U,$J,"OPT",104,"U")
 ;;=MAP POINTER RELATIONS
 ;;^UTILITY(U,$J,"OPT",158,0)
 ;;=DIVERIFY^Verify Fields^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",158,1,0)
 ;;=^^4^4^2890316^^^
 ;;^UTILITY(U,$J,"OPT",158,1,1,0)
 ;;=This option is used to double check the data that exists in a field
 ;;^UTILITY(U,$J,"OPT",158,1,2,0)
 ;;=to see that it matches the Data Dictionary specifications.  The user
 ;;^UTILITY(U,$J,"OPT",158,1,3,0)
 ;;=is allowed to store the discrepancies in a search template so that they
 ;;^UTILITY(U,$J,"OPT",158,1,4,0)
 ;;=can easily be retrieved for examination and correction.
 ;;^UTILITY(U,$J,"OPT",158,20)
 ;;=S DI=1 G EN^DIU

DIINI003
DIINI003 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",158,"U")
 ;;=VERIFY FIELDS
 ;;^UTILITY(U,$J,"OPT",159,0)
 ;;=DIXREF^Cross-Reference A Field^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",159,1,0)
 ;;=^^5^5^2890316^
 ;;^UTILITY(U,$J,"OPT",159,1,1,0)
 ;;=The Cross-Reference a Field sub-option of the Utility Functions option
 ;;^UTILITY(U,$J,"OPT",159,1,2,0)
 ;;=allows you to identify a field or sub-field for cross-referencing or
 ;;^UTILITY(U,$J,"OPT",159,1,3,0)
 ;;=for removing cross-referencing from an identified field.
 ;;^UTILITY(U,$J,"OPT",159,1,4,0)
 ;;=VA FileMan currently has seven types of cross-references -- Regular,
 ;;^UTILITY(U,$J,"OPT",159,1,5,0)
 ;;=KWIC, Mnemonic, MUMPS, Soundex, Trigger and Bulletin.
 ;;^UTILITY(U,$J,"OPT",159,20)
 ;;=S DI=2 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",159,"U")
 ;;=CROSS-REFERENCE A FIELD
 ;;^UTILITY(U,$J,"OPT",160,0)
 ;;=DIIDENT^Identifier^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",160,1,0)
 ;;=^^4^4^2890316^
 ;;^UTILITY(U,$J,"OPT",160,1,1,0)
 ;;=Use the Identifier sub-option of the Utility Functions option to associate
 ;;^UTILITY(U,$J,"OPT",160,1,2,0)
 ;;=a field with the .01 (or NAME) field of a file.  The field designated as
 ;;^UTILITY(U,$J,"OPT",160,1,3,0)
 ;;=an identifier can be displayed along with the selected entry to help
 ;;^UTILITY(U,$J,"OPT",160,1,4,0)
 ;;=a user positively identify the entry.
 ;;^UTILITY(U,$J,"OPT",160,20)
 ;;=S DI=3 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",160,"U")
 ;;=IDENTIFIER
 ;;^UTILITY(U,$J,"OPT",161,0)
 ;;=DIRDEX^Re-Index File^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",161,1,0)
 ;;=^^4^4^2890316^
 ;;^UTILITY(U,$J,"OPT",161,1,1,0)
 ;;=The Re-index a File sub-option of the Utility Functions option allows
 ;;^UTILITY(U,$J,"OPT",161,1,2,0)
 ;;=you to re-index a file.  This VA FileMan feature is especially helpful
 ;;^UTILITY(U,$J,"OPT",161,1,3,0)
 ;;=when you create a new cross reference on a field that already contains
 ;;^UTILITY(U,$J,"OPT",161,1,4,0)
 ;;=data.
 ;;^UTILITY(U,$J,"OPT",161,20)
 ;;=S DI=4 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",161,"U")
 ;;=RE-INDEX FILE
 ;;^UTILITY(U,$J,"OPT",162,0)
 ;;=DIITRAN^Input Transform (Syntax)^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",162,1,0)
 ;;=^^4^4^2901212^^^
 ;;^UTILITY(U,$J,"OPT",162,1,1,0)
 ;;=The Input Transform sub-option of the Utility Functions option allows
 ;;^UTILITY(U,$J,"OPT",162,1,2,0)
 ;;=you to enter an executable string of MUMPS code which is used to check
 ;;^UTILITY(U,$J,"OPT",162,1,3,0)
 ;;=the validity of user input and will then convert the input into an
 ;;^UTILITY(U,$J,"OPT",162,1,4,0)
 ;;=internal form for storage.
 ;;^UTILITY(U,$J,"OPT",162,20)
 ;;=Q:DUZ(0)'="@"  S DI=5 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",162,"U")
 ;;=INPUT TRANSFORM (SYNTAX)
 ;;^UTILITY(U,$J,"OPT",163,0)
 ;;=DIEDFILE^Edit File^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",163,1,0)
 ;;=^^3^3^2890316^^
 ;;^UTILITY(U,$J,"OPT",163,1,1,0)
 ;;=This option allows the user to document and control a file.  The user
 ;;^UTILITY(U,$J,"OPT",163,1,2,0)
 ;;=may describe the purpose of the file, assign it security, indicate
 ;;^UTILITY(U,$J,"OPT",163,1,3,0)
 ;;=application groups which use the file, and change the name of the file.
 ;;^UTILITY(U,$J,"OPT",163,20)
 ;;=S DI=6 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",163,"U")
 ;;=EDIT FILE
 ;;^UTILITY(U,$J,"OPT",164,0)
 ;;=DIOTRAN^Output Transform^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",164,1,0)
 ;;=^^3^3^2890316^
 ;;^UTILITY(U,$J,"OPT",164,1,1,0)
 ;;=The Output Transform sub-option of the Utility Functions option allows
 ;;^UTILITY(U,$J,"OPT",164,1,2,0)
 ;;=you to enter an executable string of MUMPS code which converts internally
 ;;^UTILITY(U,$J,"OPT",164,1,3,0)
 ;;=stored data into a readable display.
 ;;^UTILITY(U,$J,"OPT",164,20)
 ;;=S DI=7 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",164,"U")
 ;;=OUTPUT TRANSFORM
 ;;^UTILITY(U,$J,"OPT",165,0)
 ;;=DITEMP^Template Edit^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",165,1,0)
 ;;=^^4^4^2890316^
 ;;^UTILITY(U,$J,"OPT",165,1,1,0)
 ;;=The Template Edit sub-option of the Utility Functions option allows you
 ;;^UTILITY(U,$J,"OPT",165,1,2,0)
 ;;=to enter a description of any sort, print or input templates in a selected
 ;;^UTILITY(U,$J,"OPT",165,1,3,0)
 ;;=file.  These descriptions will be printed when you request a Templates
 ;;^UTILITY(U,$J,"OPT",165,1,4,0)
 ;;=Only data dictionary listing.
 ;;^UTILITY(U,$J,"OPT",165,20)
 ;;=S DI=8 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",165,"U")
 ;;=TEMPLATE EDIT

DIINI004
DIINI004 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",166,0)
 ;;=DIUNEDIT^Uneditable Data^^A^^^^^^^^^n^1^^
 ;;^UTILITY(U,$J,"OPT",166,1,0)
 ;;=^^4^4^2890316^
 ;;^UTILITY(U,$J,"OPT",166,1,1,0)
 ;;=The Uneditable Data sub-option of the Utility Functions option allows you
 ;;^UTILITY(U,$J,"OPT",166,1,2,0)
 ;;=to specify a particular field that CANNOT be edited or deleted by a user.
 ;;^UTILITY(U,$J,"OPT",166,1,3,0)
 ;;=If an uneditable data field is edited, VA FileMan will display the field
 ;;^UTILITY(U,$J,"OPT",166,1,4,0)
 ;;=value along with one of the famous 'No Editing' messages.
 ;;^UTILITY(U,$J,"OPT",166,20)
 ;;=S DI=9 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",166,"U")
 ;;=UNEDITABLE DATA
 ;;^UTILITY(U,$J,"OPT",230,0)
 ;;=DI SET MUMPS OS^Set Type of Mumps Operating System^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",230,1,0)
 ;;=^^3^3^2880712^
 ;;^UTILITY(U,$J,"OPT",230,1,1,0)
 ;;=This option allows the user to set the Type of Mumps Operating System.
 ;;^UTILITY(U,$J,"OPT",230,1,2,0)
 ;;=VA FileMan uses this to perform operating system specific functions
 ;;^UTILITY(U,$J,"OPT",230,1,3,0)
 ;;=such as determining routine existence or filing routines.
 ;;^UTILITY(U,$J,"OPT",230,25)
 ;;=OS^DINIT
 ;;^UTILITY(U,$J,"OPT",230,"U")
 ;;=SET TYPE OF MUMPS OPERATING SY
 ;;^UTILITY(U,$J,"OPT",231,0)
 ;;=DI MGMT MENU^VA FileMan Management^^M^^XUMGR^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",231,10,0)
 ;;=^19.01IP^7^7
 ;;^UTILITY(U,$J,"OPT",231,10,1,0)
 ;;=230^^6
 ;;^UTILITY(U,$J,"OPT",231,10,1,"^")
 ;;=DI SET MUMPS OS
 ;;^UTILITY(U,$J,"OPT",231,10,2,0)
 ;;=232^^5
 ;;^UTILITY(U,$J,"OPT",231,10,2,"^")
 ;;=DI REINITIALIZE
 ;;^UTILITY(U,$J,"OPT",231,10,3,0)
 ;;=235^^1
 ;;^UTILITY(U,$J,"OPT",231,10,3,"^")
 ;;=DI DD COMPILE
 ;;^UTILITY(U,$J,"OPT",231,10,4,0)
 ;;=233^^3
 ;;^UTILITY(U,$J,"OPT",231,10,4,"^")
 ;;=DI PRINT COMPILE
 ;;^UTILITY(U,$J,"OPT",231,10,5,0)
 ;;=234^^2
 ;;^UTILITY(U,$J,"OPT",231,10,5,"^")
 ;;=DI INPUT COMPILE
 ;;^UTILITY(U,$J,"OPT",231,10,6,0)
 ;;=338^^7
 ;;^UTILITY(U,$J,"OPT",231,10,6,"^")
 ;;=DIWF
 ;;^UTILITY(U,$J,"OPT",231,10,7,0)
 ;;=407^^4
 ;;^UTILITY(U,$J,"OPT",231,10,7,"^")
 ;;=DI SORT COMPILE
 ;;^UTILITY(U,$J,"OPT",231,99)
 ;;=55713,45966
 ;;^UTILITY(U,$J,"OPT",231,99.1)
 ;;=55799,10811
 ;;^UTILITY(U,$J,"OPT",231,"U")
 ;;=VA FILEMAN MANAGEMENT
 ;;^UTILITY(U,$J,"OPT",232,0)
 ;;=DI REINITIALIZE^Re-Initialize VA FileMan^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",232,25)
 ;;=DINIT
 ;;^UTILITY(U,$J,"OPT",232,"U")
 ;;=RE-INITIALIZE VA FILEMAN
 ;;^UTILITY(U,$J,"OPT",233,0)
 ;;=DI PRINT COMPILE^Print Template Compile/Uncompile^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",233,1,0)
 ;;=^^1^1^2930715^^
 ;;^UTILITY(U,$J,"OPT",233,1,1,0)
 ;;=This option allows the user to compile or uncompile a print template.
 ;;^UTILITY(U,$J,"OPT",233,25)
 ;;=EN1^DIPZ
 ;;^UTILITY(U,$J,"OPT",233,"U")
 ;;=PRINT TEMPLATE COMPILE/UNCOMPI
 ;;^UTILITY(U,$J,"OPT",234,0)
 ;;=DI INPUT COMPILE^Input Template Compile/Uncompile^^A^^^^^^^^VA FILEMAN^^1^^
 ;;^UTILITY(U,$J,"OPT",234,1,0)
 ;;=^^1^1^2930715^^^^
 ;;^UTILITY(U,$J,"OPT",234,1,1,0)
 ;;=This option allows the user to compile or uncompile an Input Template.
 ;;^UTILITY(U,$J,"OPT",234,20)
 ;;=D EN1^DIEZ K DNM
 ;;^UTILITY(U,$J,"OPT",234,"U")
 ;;=INPUT TEMPLATE COMPILE/UNCOMPI
 ;;^UTILITY(U,$J,"OPT",235,0)
 ;;=DI DD COMPILE^Data Dictionary Cross-reference Compile/Uncompile^^R^^^^^^^^VA FILEMAN^^
 ;;^UTILITY(U,$J,"OPT",235,1,0)
 ;;=^^3^3^2930715^^^^
 ;;^UTILITY(U,$J,"OPT",235,1,1,0)
 ;;=This option allows the user to compile or uncompile a Data Dictionary's
 ;;^UTILITY(U,$J,"OPT",235,1,2,0)
 ;;=cross-references into routines which are run whenever an entry
 ;;^UTILITY(U,$J,"OPT",235,1,3,0)
 ;;=is indexed or deleted.
 ;;^UTILITY(U,$J,"OPT",235,25)
 ;;=EN1^DIKZ
 ;;^UTILITY(U,$J,"OPT",235,"U")
 ;;=DATA DICTIONARY CROSS-REFERENC
 ;;^UTILITY(U,$J,"OPT",287,0)
 ;;=DIAUDIT^Audit Menu^^M^^XUAUDITING^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",287,1,0)
 ;;=^^2^2^2901206^^
 ;;^UTILITY(U,$J,"OPT",287,1,1,0)
 ;;=This menu contains the options which show which files and fields are
 ;;^UTILITY(U,$J,"OPT",287,1,2,0)
 ;;=being audited as well as the options which purge audit trails.
 ;;^UTILITY(U,$J,"OPT",287,10,0)
 ;;=^19.01IP^5^5
 ;;^UTILITY(U,$J,"OPT",287,10,1,0)
 ;;=288^^1
 ;;^UTILITY(U,$J,"OPT",287,10,1,"^")
 ;;=DIAUDITED FIELDS
 ;;^UTILITY(U,$J,"OPT",287,10,2,0)
 ;;=289^^2
 ;;^UTILITY(U,$J,"OPT",287,10,2,"^")
 ;;=DIAUDIT DD
 ;;^UTILITY(U,$J,"OPT",287,10,3,0)
 ;;=290^^3
 ;;^UTILITY(U,$J,"OPT",287,10,3,"^")
 ;;=DIAUDIT PURGE DATA

DIINI005
DIINI005 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",287,10,4,0)
 ;;=291^^4
 ;;^UTILITY(U,$J,"OPT",287,10,4,"^")
 ;;=DIAUDIT PURGE DD
 ;;^UTILITY(U,$J,"OPT",287,10,5,0)
 ;;=337^^5
 ;;^UTILITY(U,$J,"OPT",287,10,5,"^")
 ;;=DIAUDIT TURN ON/OFF
 ;;^UTILITY(U,$J,"OPT",287,99)
 ;;=55633,47284
 ;;^UTILITY(U,$J,"OPT",287,"U")
 ;;=AUDIT MENU
 ;;^UTILITY(U,$J,"OPT",288,0)
 ;;=DIAUDITED FIELDS^Fields Being Audited^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",288,1,0)
 ;;=^^2^2^2930125^^^
 ;;^UTILITY(U,$J,"OPT",288,1,1,0)
 ;;=This options lists all the fields that are being audited.  One can
 ;;^UTILITY(U,$J,"OPT",288,1,2,0)
 ;;=see all the fields or just those in a particular file range.
 ;;^UTILITY(U,$J,"OPT",288,25)
 ;;=1^DIAU
 ;;^UTILITY(U,$J,"OPT",288,"U")
 ;;=FIELDS BEING AUDITED
 ;;^UTILITY(U,$J,"OPT",289,0)
 ;;=DIAUDIT DD^Data Dictionaries Being Audited^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",289,1,0)
 ;;=^^2^2^2890803^
 ;;^UTILITY(U,$J,"OPT",289,1,1,0)
 ;;=This option lists the data dictionaries being audited within a selected
 ;;^UTILITY(U,$J,"OPT",289,1,2,0)
 ;;=range.
 ;;^UTILITY(U,$J,"OPT",289,25)
 ;;=2^DIAU
 ;;^UTILITY(U,$J,"OPT",289,"U")
 ;;=DATA DICTIONARIES BEING AUDITE
 ;;^UTILITY(U,$J,"OPT",290,0)
 ;;=DIAUDIT PURGE DATA^Purge Data Audits^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",290,1,0)
 ;;=^^3^3^2890804^^
 ;;^UTILITY(U,$J,"OPT",290,1,1,0)
 ;;=This option purges the audited data from a particular file.  Either all
 ;;^UTILITY(U,$J,"OPT",290,1,2,0)
 ;;=of the audits may be purged or the audits may be deleted based on a
 ;;^UTILITY(U,$J,"OPT",290,1,3,0)
 ;;=field in the audit file, e.g., date, user, field.
 ;;^UTILITY(U,$J,"OPT",290,25)
 ;;=3^DIAU
 ;;^UTILITY(U,$J,"OPT",290,99.1)
 ;;=56123,39787
 ;;^UTILITY(U,$J,"OPT",290,"U")
 ;;=PURGE DATA AUDITS
 ;;^UTILITY(U,$J,"OPT",291,0)
 ;;=DIAUDIT PURGE DD^Purge DD Audits^^R^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",291,25)
 ;;=4^DIAU
 ;;^UTILITY(U,$J,"OPT",291,"U")
 ;;=PURGE DD AUDITS
 ;;^UTILITY(U,$J,"OPT",292,0)
 ;;=DIOTHER^Other Options^^M^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",292,1,0)
 ;;=^^3^3^2921207^^^^
 ;;^UTILITY(U,$J,"OPT",292,1,1,0)
 ;;=This menu contains a series of menus which lead to enhancements in current
 ;;^UTILITY(U,$J,"OPT",292,1,2,0)
 ;;=and coming versions.  These include auditing, filegrams, and FileMan 
 ;;^UTILITY(U,$J,"OPT",292,1,3,0)
 ;;=management.
 ;;^UTILITY(U,$J,"OPT",292,10,0)
 ;;=^19.01IP^8^8
 ;;^UTILITY(U,$J,"OPT",292,10,1,0)
 ;;=231^^5
 ;;^UTILITY(U,$J,"OPT",292,10,1,"^")
 ;;=DI MGMT MENU
 ;;^UTILITY(U,$J,"OPT",292,10,2,0)
 ;;=287^^2
 ;;^UTILITY(U,$J,"OPT",292,10,2,"^")
 ;;=DIAUDIT
 ;;^UTILITY(U,$J,"OPT",292,10,3,0)
 ;;=15^^4
 ;;^UTILITY(U,$J,"OPT",292,10,3,"^")
 ;;=DISTATISTICS
 ;;^UTILITY(U,$J,"OPT",292,10,4,0)
 ;;=327^^1
 ;;^UTILITY(U,$J,"OPT",292,10,4,"^")
 ;;=DIFG
 ;;^UTILITY(U,$J,"OPT",292,10,5,0)
 ;;=294^^3
 ;;^UTILITY(U,$J,"OPT",292,10,5,"^")
 ;;=DDS SCREEN MENU
 ;;^UTILITY(U,$J,"OPT",292,10,6,0)
 ;;=394^^6
 ;;^UTILITY(U,$J,"OPT",292,10,6,"^")
 ;;=DDXP EXPORT MENU
 ;;^UTILITY(U,$J,"OPT",292,10,7,0)
 ;;=395^^7
 ;;^UTILITY(U,$J,"OPT",292,10,7,"^")
 ;;=DIAX EXTRACT MENU
 ;;^UTILITY(U,$J,"OPT",292,10,8,0)
 ;;=503^
 ;;^UTILITY(U,$J,"OPT",292,10,8,"^")
 ;;=DDBROWSER
 ;;^UTILITY(U,$J,"OPT",292,99)
 ;;=56021,58310
 ;;^UTILITY(U,$J,"OPT",292,"U")
 ;;=OTHER OPTIONS
 ;;^UTILITY(U,$J,"OPT",293,0)
 ;;=DDS EDIT/CREATE A FORM^Edit/Create a Form^^R^^^^^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",293,1,0)
 ;;=^^2^2^2940630^
 ;;^UTILITY(U,$J,"OPT",293,1,1,0)
 ;;=An option for editing and creating ScreenMan Forms.  This option calls the
 ;;^UTILITY(U,$J,"OPT",293,1,2,0)
 ;;=Form Editor.
 ;;^UTILITY(U,$J,"OPT",293,20)
 ;;=
 ;;^UTILITY(U,$J,"OPT",293,25)
 ;;=1^DDSOPT
 ;;^UTILITY(U,$J,"OPT",293,99)
 ;;=54872,31063
 ;;^UTILITY(U,$J,"OPT",293,"U")
 ;;=EDIT/CREATE A FORM
 ;;^UTILITY(U,$J,"OPT",294,0)
 ;;=DDS SCREEN MENU^ScreenMan^^M^^XUSCREENMAN^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",294,10,0)
 ;;=^19.01IP^4^4
 ;;^UTILITY(U,$J,"OPT",294,10,1,0)
 ;;=293^^1^Enter/Edit Screen Definition
 ;;^UTILITY(U,$J,"OPT",294,10,1,"^")
 ;;=DDS EDIT/CREATE A FORM
 ;;^UTILITY(U,$J,"OPT",294,10,2,0)
 ;;=360^^2
 ;;^UTILITY(U,$J,"OPT",294,10,2,"^")
 ;;=DDS RUN A FORM
 ;;^UTILITY(U,$J,"OPT",294,10,3,0)
 ;;=509^^3
 ;;^UTILITY(U,$J,"OPT",294,10,3,"^")
 ;;=DDS DELETE A FORM
 ;;^UTILITY(U,$J,"OPT",294,10,4,0)
 ;;=510^^4
 ;;^UTILITY(U,$J,"OPT",294,10,4,"^")
 ;;=DDS PURGE UNUSED BLOCKS
 ;;^UTILITY(U,$J,"OPT",294,99)
 ;;=56078,27325
 ;;^UTILITY(U,$J,"OPT",294,"U")
 ;;=SCREENMAN

DIINI006
DIINI006 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",321,0)
 ;;=DIFG CREATE^Create/Edit Filegram Template^^A^^XUFILEGRAM^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",321,1,0)
 ;;=^^4^4^2900124^
 ;;^UTILITY(U,$J,"OPT",321,1,1,0)
 ;;=Use this option to create a filegram template or edit an existing
 ;;^UTILITY(U,$J,"OPT",321,1,2,0)
 ;;=filegram template.  This option is the first step in developing a
 ;;^UTILITY(U,$J,"OPT",321,1,3,0)
 ;;=filegram and is very important since there won't be filegrams without
 ;;^UTILITY(U,$J,"OPT",321,1,4,0)
 ;;=this template.
 ;;^UTILITY(U,$J,"OPT",321,20)
 ;;=S DI=1 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",321,"U")
 ;;=CREATE/EDIT FILEGRAM TEMPLATE
 ;;^UTILITY(U,$J,"OPT",322,0)
 ;;=DIFG DISPLAY^Display Filegram Template^^A^^XUFILEGRAM^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",322,1,0)
 ;;=^^2^2^2900124^
 ;;^UTILITY(U,$J,"OPT",322,1,1,0)
 ;;=Use this option to display the filegram template in a two-column
 ;;^UTILITY(U,$J,"OPT",322,1,2,0)
 ;;=format (similar to FileMan's Inquire to File Entries option).
 ;;^UTILITY(U,$J,"OPT",322,20)
 ;;=S DI=2 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",322,"U")
 ;;=DISPLAY FILEGRAM TEMPLATE
 ;;^UTILITY(U,$J,"OPT",323,0)
 ;;=DIFG GENERATE^Generate Filegram^^A^^XUFILEGRAM^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",323,1,0)
 ;;=^^3^3^2900124^
 ;;^UTILITY(U,$J,"OPT",323,1,1,0)
 ;;=Use this option to generate a filegram into a MailMan message after
 ;;^UTILITY(U,$J,"OPT",323,1,2,0)
 ;;=selecting the file, filegram template and an entry.  It's a good idea
 ;;^UTILITY(U,$J,"OPT",323,1,3,0)
 ;;=to know that information before using this option.
 ;;^UTILITY(U,$J,"OPT",323,20)
 ;;=S DI=3 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",323,"U")
 ;;=GENERATE FILEGRAM
 ;;^UTILITY(U,$J,"OPT",324,0)
 ;;=DIFG VIEW^View Filegram^^A^^^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",324,1,0)
 ;;=^^1^1^2900124^
 ;;^UTILITY(U,$J,"OPT",324,1,1,0)
 ;;=Use this option to view the filegram in filegram format.
 ;;^UTILITY(U,$J,"OPT",324,20)
 ;;=S DI=4 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",324,"U")
 ;;=VIEW FILEGRAM
 ;;^UTILITY(U,$J,"OPT",325,0)
 ;;=DIFG SPECIFIERS^Specifiers^^A^^XUFILEGRAM^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",325,1,0)
 ;;=^^6^6^2900124^
 ;;^UTILITY(U,$J,"OPT",325,1,1,0)
 ;;=Use this option to identify a particular field in the file as a
 ;;^UTILITY(U,$J,"OPT",325,1,2,0)
 ;;=reference point for FileMan to use when installing the filegram.
 ;;^UTILITY(U,$J,"OPT",325,1,3,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",325,1,4,0)
 ;;=Specifiers can be compared to FileMan's identifier, unlike identifiers
 ;;^UTILITY(U,$J,"OPT",325,1,5,0)
 ;;=which are used for interaction purposes...specifiers are used for
 ;;^UTILITY(U,$J,"OPT",325,1,6,0)
 ;;=transaction purposes.
 ;;^UTILITY(U,$J,"OPT",325,20)
 ;;=S DI=5 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",325,"U")
 ;;=SPECIFIERS
 ;;^UTILITY(U,$J,"OPT",326,0)
 ;;=DIFG INSTALL^Install/Verify Filegram^^A^^XUFILEGRAM^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",326,1,0)
 ;;=^^2^2^2900124^^
 ;;^UTILITY(U,$J,"OPT",326,1,1,0)
 ;;=Use this option to install the filegram in a FileMan file
 ;;^UTILITY(U,$J,"OPT",326,1,2,0)
 ;;=from a MailMan message format.  A message of verification should return.
 ;;^UTILITY(U,$J,"OPT",326,20)
 ;;=S DI=6 D EN^DIFGO
 ;;^UTILITY(U,$J,"OPT",326,"U")
 ;;=INSTALL/VERIFY FILEGRAM
 ;;^UTILITY(U,$J,"OPT",327,0)
 ;;=DIFG^Filegrams^^M^^XUFILEGRAM^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",327,1,0)
 ;;=^^1^1^2900124^^^
 ;;^UTILITY(U,$J,"OPT",327,1,1,0)
 ;;=This is a menu of the Filegram options.
 ;;^UTILITY(U,$J,"OPT",327,10,0)
 ;;=^19.01IP^6^6
 ;;^UTILITY(U,$J,"OPT",327,10,1,0)
 ;;=321^^1
 ;;^UTILITY(U,$J,"OPT",327,10,1,"^")
 ;;=DIFG CREATE
 ;;^UTILITY(U,$J,"OPT",327,10,2,0)
 ;;=322^^2
 ;;^UTILITY(U,$J,"OPT",327,10,2,"^")
 ;;=DIFG DISPLAY
 ;;^UTILITY(U,$J,"OPT",327,10,3,0)
 ;;=323^^3
 ;;^UTILITY(U,$J,"OPT",327,10,3,"^")
 ;;=DIFG GENERATE
 ;;^UTILITY(U,$J,"OPT",327,10,4,0)
 ;;=324^^4
 ;;^UTILITY(U,$J,"OPT",327,10,4,"^")
 ;;=DIFG VIEW
 ;;^UTILITY(U,$J,"OPT",327,10,5,0)
 ;;=325^^5
 ;;^UTILITY(U,$J,"OPT",327,10,5,"^")
 ;;=DIFG SPECIFIERS
 ;;^UTILITY(U,$J,"OPT",327,10,6,0)
 ;;=326^^6
 ;;^UTILITY(U,$J,"OPT",327,10,6,"^")
 ;;=DIFG INSTALL
 ;;^UTILITY(U,$J,"OPT",327,99)
 ;;=55633,47328
 ;;^UTILITY(U,$J,"OPT",327,99.1)
 ;;=54674,36753
 ;;^UTILITY(U,$J,"OPT",327,"U")
 ;;=FILEGRAMS
 ;;^UTILITY(U,$J,"OPT",336,0)
 ;;=DIFIELD CHECK^Mandatory/Required Field Check^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",336,1,0)
 ;;=^^1^1^2901205^
 ;;^UTILITY(U,$J,"OPT",336,1,1,0)
 ;;=Kernel option to emulate the VA FileMan option to check fields for required data.

DIINI007
DIINI007 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",336,20)
 ;;=S DI=10 G EN^DIU
 ;;^UTILITY(U,$J,"OPT",336,"U")
 ;;=MANDATORY/REQUIRED FIELD CHECK
 ;;^UTILITY(U,$J,"OPT",337,0)
 ;;=DIAUDIT TURN ON/OFF^Turn Data Audit On/Off^^R^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",337,1,0)
 ;;=^^4^4^2901206^
 ;;^UTILITY(U,$J,"OPT",337,1,1,0)
 ;;=This option allows the user to start or stop an audit on a particular
 ;;^UTILITY(U,$J,"OPT",337,1,2,0)
 ;;=data field.  The user must have audit access to the file in order to turn
 ;;^UTILITY(U,$J,"OPT",337,1,3,0)
 ;;=an audit on or off.  No other attributes in the field definition can 
 ;;^UTILITY(U,$J,"OPT",337,1,4,0)
 ;;=be affected by this option.
 ;;^UTILITY(U,$J,"OPT",337,25)
 ;;=5^DIAU
 ;;^UTILITY(U,$J,"OPT",337,"U")
 ;;=TURN DATA AUDIT ON/OFF
 ;;^UTILITY(U,$J,"OPT",338,0)
 ;;=DIWF^Forms Print^^R^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",338,1,0)
 ;;=^^7^7^2901206^
 ;;^UTILITY(U,$J,"OPT",338,1,1,0)
 ;;=This VA FileMan routine asks first for a 'document' file, which must be
 ;;^UTILITY(U,$J,"OPT",338,1,2,0)
 ;;=a file that contains a word processing field at the first level.  It then
 ;;^UTILITY(U,$J,"OPT",338,1,3,0)
 ;;=asks the user to choose an entry in that file for which the word
 ;;^UTILITY(U,$J,"OPT",338,1,4,0)
 ;;=processing field has some text on file.  It then uses that text as a 
 ;;^UTILITY(U,$J,"OPT",338,1,5,0)
 ;;='print template' for a file.  If the chosen document entry has a pointer
 ;;^UTILITY(U,$J,"OPT",338,1,6,0)
 ;;=to a file, that file is automatically the one from which the printing
 ;;^UTILITY(U,$J,"OPT",338,1,7,0)
 ;;=is done.
 ;;^UTILITY(U,$J,"OPT",338,25)
 ;;=DIWF
 ;;^UTILITY(U,$J,"OPT",338,"U")
 ;;=FORMS PRINT
 ;;^UTILITY(U,$J,"OPT",348,0)
 ;;=DI DDUCHK^Check/Fix DD Structure^^R^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",348,1,0)
 ;;=^^4^4^2930125^
 ;;^UTILITY(U,$J,"OPT",348,1,1,0)
 ;;=This option looks at the internal structure of files and subfiles
 ;;^UTILITY(U,$J,"OPT",348,1,2,0)
 ;;=and determines if there are inconsistencies or conflicts between the
 ;;^UTILITY(U,$J,"OPT",348,1,3,0)
 ;;=information in the data dictionary and the structure of the file's global
 ;;^UTILITY(U,$J,"OPT",348,1,4,0)
 ;;=nodes.  This option will note them and fix or delete the incorrect nodes.
 ;;^UTILITY(U,$J,"OPT",348,25)
 ;;=DDUCHK
 ;;^UTILITY(U,$J,"OPT",348,"U")
 ;;=CHECK/FIX DD STRUCTURE
 ;;^UTILITY(U,$J,"OPT",349,0)
 ;;=DI DDU^Data Dictionary Utilities^^M^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",349,10,0)
 ;;=^19.01IP^3^3
 ;;^UTILITY(U,$J,"OPT",349,10,1,0)
 ;;=16^^1
 ;;^UTILITY(U,$J,"OPT",349,10,1,"^")
 ;;=DILIST
 ;;^UTILITY(U,$J,"OPT",349,10,2,0)
 ;;=104^^2
 ;;^UTILITY(U,$J,"OPT",349,10,2,"^")
 ;;=DI DDMAP
 ;;^UTILITY(U,$J,"OPT",349,10,3,0)
 ;;=348^^3
 ;;^UTILITY(U,$J,"OPT",349,10,3,"^")
 ;;=DI DDUCHK
 ;;^UTILITY(U,$J,"OPT",349,99)
 ;;=55633,47339
 ;;^UTILITY(U,$J,"OPT",349,"U")
 ;;=DATA DICTIONARY UTILITIES
 ;;^UTILITY(U,$J,"OPT",360,0)
 ;;=DDS RUN A FORM^Run a Form^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",360,1,0)
 ;;=^^1^1^2940701^^
 ;;^UTILITY(U,$J,"OPT",360,1,1,0)
 ;;=Option to run a form.
 ;;^UTILITY(U,$J,"OPT",360,20)
 ;;=D 2^DDSOPT
 ;;^UTILITY(U,$J,"OPT",360,99.1)
 ;;=56123,39787
 ;;^UTILITY(U,$J,"OPT",360,"U")
 ;;=RUN A FORM
 ;;^UTILITY(U,$J,"OPT",384,0)
 ;;=DIFG-SRV-HISTORY^Server to Load a Message into the FG History File^^S^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",384,1,0)
 ;;=^^2^2^2920420^
 ;;^UTILITY(U,$J,"OPT",384,1,1,0)
 ;;=This option is a SERVER that will take a message and add it to the 
 ;;^UTILITY(U,$J,"OPT",384,1,2,0)
 ;;=Filegram History file so that it can be installed.
 ;;^UTILITY(U,$J,"OPT",384,3.91,0)
 ;;=^19.391^^0
 ;;^UTILITY(U,$J,"OPT",384,25)
 ;;=HIST^DIFGSRV
 ;;^UTILITY(U,$J,"OPT",384,220)
 ;;=^R^^N^N^N
 ;;^UTILITY(U,$J,"OPT",384,"U")
 ;;=SERVER TO LOAD A MESSAGE INTO 
 ;;^UTILITY(U,$J,"OPT",390,0)
 ;;=DDXP DEFINE FORMAT^Define Foreign File Format^^A^^DDXP-DEFINE^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",390,1,0)
 ;;=^^5^5^2930108^
 ;;^UTILITY(U,$J,"OPT",390,1,1,0)
 ;;=Use this option to define formats.  Formats are entries in the Foreign
 ;;^UTILITY(U,$J,"OPT",390,1,2,0)
 ;;=Format file.  They are used to control the exporting of data to a
 ;;^UTILITY(U,$J,"OPT",390,1,3,0)
 ;;=non-MUMPS application.  You can alter an existing format only before it has
 ;;^UTILITY(U,$J,"OPT",390,1,4,0)
 ;;=been used to create an Export template.  After it has been used, you can
 ;;^UTILITY(U,$J,"OPT",390,1,5,0)
 ;;=clone a format.  This option is locked with the DDXP-DEFINE key.

DIINI008
DIINI008 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",390,20)
 ;;=D 1^DDXP
 ;;^UTILITY(U,$J,"OPT",390,"U")
 ;;=DEFINE FOREIGN FILE FORMAT
 ;;^UTILITY(U,$J,"OPT",391,0)
 ;;=DDXP SELECT EXPORT FIELDS^Select Fields for Export^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",391,1,0)
 ;;=^^1^1^2921207^^
 ;;^UTILITY(U,$J,"OPT",391,1,1,0)
 ;;=Use this option to choose fields to be exported.
 ;;^UTILITY(U,$J,"OPT",391,20)
 ;;=D 2^DDXP
 ;;^UTILITY(U,$J,"OPT",391,"U")
 ;;=SELECT FIELDS FOR EXPORT
 ;;^UTILITY(U,$J,"OPT",392,0)
 ;;=DDXP CREATE EXPORT TEMPLATE^Create Export Template^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",392,1,0)
 ;;=^^2^2^2940519^^^
 ;;^UTILITY(U,$J,"OPT",392,1,1,0)
 ;;=This option creates an Export template by applying the specifications in a
 ;;^UTILITY(U,$J,"OPT",392,1,2,0)
 ;;=Foreign Format with the fields in a Selected Fields for Export template.
 ;;^UTILITY(U,$J,"OPT",392,20)
 ;;=D 3^DDXP
 ;;^UTILITY(U,$J,"OPT",392,"U")
 ;;=CREATE EXPORT TEMPLATE
 ;;^UTILITY(U,$J,"OPT",393,0)
 ;;=DDXP EXPORT DATA^Export Data^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",393,1,0)
 ;;=^^4^4^2921207^^
 ;;^UTILITY(U,$J,"OPT",393,1,1,0)
 ;;=This option sends data to a specified device for export to a foreign
 ;;^UTILITY(U,$J,"OPT",393,1,2,0)
 ;;=application.  You have the opportunity to choose entries for export with
 ;;^UTILITY(U,$J,"OPT",393,1,3,0)
 ;;=VA FileMan's Search dialogue.  You use an Export template to control the
 ;;^UTILITY(U,$J,"OPT",393,1,4,0)
 ;;=export.
 ;;^UTILITY(U,$J,"OPT",393,20)
 ;;=D 4^DDXP
 ;;^UTILITY(U,$J,"OPT",393,"U")
 ;;=EXPORT DATA
 ;;^UTILITY(U,$J,"OPT",394,0)
 ;;=DDXP EXPORT MENU^Data Export to Foreign Format^^M^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",394,1,0)
 ;;=^^1^1^2921207^
 ;;^UTILITY(U,$J,"OPT",394,1,1,0)
 ;;=Submenu for the Export tool.
 ;;^UTILITY(U,$J,"OPT",394,10,0)
 ;;=^19.01IP^5^5
 ;;^UTILITY(U,$J,"OPT",394,10,1,0)
 ;;=390^^1
 ;;^UTILITY(U,$J,"OPT",394,10,1,"^")
 ;;=DDXP DEFINE FORMAT
 ;;^UTILITY(U,$J,"OPT",394,10,2,0)
 ;;=391^^2
 ;;^UTILITY(U,$J,"OPT",394,10,2,"^")
 ;;=DDXP SELECT EXPORT FIELDS
 ;;^UTILITY(U,$J,"OPT",394,10,3,0)
 ;;=392^^3
 ;;^UTILITY(U,$J,"OPT",394,10,3,"^")
 ;;=DDXP CREATE EXPORT TEMPLATE
 ;;^UTILITY(U,$J,"OPT",394,10,4,0)
 ;;=393^^4
 ;;^UTILITY(U,$J,"OPT",394,10,4,"^")
 ;;=DDXP EXPORT DATA
 ;;^UTILITY(U,$J,"OPT",394,10,5,0)
 ;;=405^^5
 ;;^UTILITY(U,$J,"OPT",394,10,5,"^")
 ;;=DDXP FORMAT DOCUMENTATION
 ;;^UTILITY(U,$J,"OPT",394,99)
 ;;=55633,47255
 ;;^UTILITY(U,$J,"OPT",394,"U")
 ;;=DATA EXPORT TO FOREIGN FORMAT
 ;;^UTILITY(U,$J,"OPT",395,0)
 ;;=DIAX EXTRACT MENU^Extract Data To Fileman File^^M^^DIEXTRACT^^^^^^^^^1^^
 ;;^UTILITY(U,$J,"OPT",395,1,0)
 ;;=^^2^2^2921222^^^^
 ;;^UTILITY(U,$J,"OPT",395,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",395,1,2,0)
 ;;=This is a menu of the tool for extracting data to Fileman file.
 ;;^UTILITY(U,$J,"OPT",395,10,0)
 ;;=^19.01IP^9^9
 ;;^UTILITY(U,$J,"OPT",395,10,1,0)
 ;;=396^^1
 ;;^UTILITY(U,$J,"OPT",395,10,1,"^")
 ;;=DIAX SELECT
 ;;^UTILITY(U,$J,"OPT",395,10,2,0)
 ;;=397^^2
 ;;^UTILITY(U,$J,"OPT",395,10,2,"^")
 ;;=DIAX ADD/DELETE
 ;;^UTILITY(U,$J,"OPT",395,10,3,0)
 ;;=398^^3
 ;;^UTILITY(U,$J,"OPT",395,10,3,"^")
 ;;=DIAX PRINT
 ;;^UTILITY(U,$J,"OPT",395,10,4,0)
 ;;=399^^4
 ;;^UTILITY(U,$J,"OPT",395,10,4,"^")
 ;;=DIAX MODIFY
 ;;^UTILITY(U,$J,"OPT",395,10,5,0)
 ;;=400^^5
 ;;^UTILITY(U,$J,"OPT",395,10,5,"^")
 ;;=DIAX CREATE
 ;;^UTILITY(U,$J,"OPT",395,10,6,0)
 ;;=401^^6
 ;;^UTILITY(U,$J,"OPT",395,10,6,"^")
 ;;=DIAX UPDATE
 ;;^UTILITY(U,$J,"OPT",395,10,7,0)
 ;;=402^^7
 ;;^UTILITY(U,$J,"OPT",395,10,7,"^")
 ;;=DIAX PURGE
 ;;^UTILITY(U,$J,"OPT",395,10,8,0)
 ;;=403^^7
 ;;^UTILITY(U,$J,"OPT",395,10,8,"^")
 ;;=DIAX CANCEL
 ;;^UTILITY(U,$J,"OPT",395,10,9,0)
 ;;=404^^8
 ;;^UTILITY(U,$J,"OPT",395,10,9,"^")
 ;;=DIAX VALIDATE
 ;;^UTILITY(U,$J,"OPT",395,15)
 ;;=K DIAX
 ;;^UTILITY(U,$J,"OPT",395,99)
 ;;=55633,47310
 ;;^UTILITY(U,$J,"OPT",395,"U")
 ;;=EXTRACT DATA TO FILEMAN FILE
 ;;^UTILITY(U,$J,"OPT",396,0)
 ;;=DIAX SELECT^Select Entries to Extract^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",396,1,0)
 ;;=^^5^5^2921222^
 ;;^UTILITY(U,$J,"OPT",396,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",396,1,2,0)
 ;;=Use this option to specify the criteria that would select Fileman entries
 ;;^UTILITY(U,$J,"OPT",396,1,3,0)
 ;;=to extract.  This is the first step in developing an extract activity and
 ;;^UTILITY(U,$J,"OPT",396,1,4,0)
 ;;=is important since there cannot be any extract process without the search
 ;;^UTILITY(U,$J,"OPT",396,1,5,0)
 ;;=template created in this option.

DIINI009
DIINI009 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",396,20)
 ;;=S DI=1 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",396,"U")
 ;;=SELECT ENTRIES TO EXTRACT
 ;;^UTILITY(U,$J,"OPT",397,0)
 ;;=DIAX ADD/DELETE^Add/Delete Selected Entries^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",397,1,0)
 ;;=^^3^3^2921222^
 ;;^UTILITY(U,$J,"OPT",397,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",397,1,2,0)
 ;;=Use this option to edit the list of selected entries to extract by adding
 ;;^UTILITY(U,$J,"OPT",397,1,3,0)
 ;;=needed entries or by deleting undesired ones.
 ;;^UTILITY(U,$J,"OPT",397,20)
 ;;=S DI=2 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",397,"U")
 ;;=ADD/DELETE SELECTED ENTRIES
 ;;^UTILITY(U,$J,"OPT",398,0)
 ;;=DIAX PRINT^Print Selected Entries^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",398,1,0)
 ;;=^^3^3^2921222^
 ;;^UTILITY(U,$J,"OPT",398,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",398,1,2,0)
 ;;=Use this option to display the list of entries selected for extract.  This
 ;;^UTILITY(U,$J,"OPT",398,1,3,0)
 ;;=option uses the standard VA Fileman interface for printing.
 ;;^UTILITY(U,$J,"OPT",398,20)
 ;;=S DI=3 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",398,"U")
 ;;=PRINT SELECTED ENTRIES
 ;;^UTILITY(U,$J,"OPT",399,0)
 ;;=DIAX MODIFY^Modify Destination File^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",399,1,0)
 ;;=^^3^3^2921222^
 ;;^UTILITY(U,$J,"OPT",399,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",399,1,2,0)
 ;;=Use this option to create a destination file that will hold the data
 ;;^UTILITY(U,$J,"OPT",399,1,3,0)
 ;;=extracted from the source entries.
 ;;^UTILITY(U,$J,"OPT",399,20)
 ;;=S DI=4 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",399,"U")
 ;;=MODIFY DESTINATION FILE
 ;;^UTILITY(U,$J,"OPT",400,0)
 ;;=DIAX CREATE^Create Extract Template^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",400,1,0)
 ;;=^^4^4^2930104^
 ;;^UTILITY(U,$J,"OPT",400,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",400,1,2,0)
 ;;=Use this option to identify the fields to be extracted from the source
 ;;^UTILITY(U,$J,"OPT",400,1,3,0)
 ;;=file and the fields in the destination file where the extracted data will
 ;;^UTILITY(U,$J,"OPT",400,1,4,0)
 ;;=be stored.
 ;;^UTILITY(U,$J,"OPT",400,20)
 ;;=S DI=5 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",400,"U")
 ;;=CREATE EXTRACT TEMPLATE
 ;;^UTILITY(U,$J,"OPT",401,0)
 ;;=DIAX UPDATE^Update Destination File^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",401,1,0)
 ;;=^^3^3^2921222^
 ;;^UTILITY(U,$J,"OPT",401,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",401,1,2,0)
 ;;=Use this option to extract data from the source file and move it to the
 ;;^UTILITY(U,$J,"OPT",401,1,3,0)
 ;;=destination file.
 ;;^UTILITY(U,$J,"OPT",401,20)
 ;;=S DI=6 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",401,"U")
 ;;=UPDATE DESTINATION FILE
 ;;^UTILITY(U,$J,"OPT",402,0)
 ;;=DIAX PURGE^Purge Extracted Entries^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",402,1,0)
 ;;=^^2^2^2921222^
 ;;^UTILITY(U,$J,"OPT",402,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",402,1,2,0)
 ;;=Use this option to delete the extracted data from the primary file.
 ;;^UTILITY(U,$J,"OPT",402,20)
 ;;=S DI=7 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",402,"U")
 ;;=PURGE EXTRACTED ENTRIES
 ;;^UTILITY(U,$J,"OPT",403,0)
 ;;=DIAX CANCEL^Cancel Extract Selection^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",403,1,0)
 ;;=^^3^3^2921222^
 ;;^UTILITY(U,$J,"OPT",403,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",403,1,2,0)
 ;;=Use this option to cancel an extract activity any time before the selected
 ;;^UTILITY(U,$J,"OPT",403,1,3,0)
 ;;=entries in the primary file are purged.
 ;;^UTILITY(U,$J,"OPT",403,20)
 ;;=S DI=8 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",403,"U")
 ;;=CANCEL EXTRACT SELECTION
 ;;^UTILITY(U,$J,"OPT",404,0)
 ;;=DIAX VALIDATE^Validate Extract Template^^A^^DIEXTRACT^^^^^^^^1^^^
 ;;^UTILITY(U,$J,"OPT",404,1,0)
 ;;=^^3^3^2930104^
 ;;^UTILITY(U,$J,"OPT",404,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"OPT",404,1,2,0)
 ;;=Use this option to verify the compatibility between fields to be extracted
 ;;^UTILITY(U,$J,"OPT",404,1,3,0)
 ;;=and their corresponding destination fields in the destination file.
 ;;^UTILITY(U,$J,"OPT",404,20)
 ;;=S DI=9 D EN^DIAX
 ;;^UTILITY(U,$J,"OPT",404,"U")
 ;;=VALIDATE EXTRACT TEMPLATE
 ;;^UTILITY(U,$J,"OPT",405,0)
 ;;=DDXP FORMAT DOCUMENTATION^Print Format Documentation^^A^^^^^^^^^^1
 ;;^UTILITY(U,$J,"OPT",405,1,0)
 ;;=^^2^2^2921207^^
 ;;^UTILITY(U,$J,"OPT",405,1,1,0)
 ;;=Use this option ot print documentation for existing entries in the Foreign
 ;;^UTILITY(U,$J,"OPT",405,1,2,0)
 ;;=Format file.

DIINI00A
DIINI00A ; ;6/20/96  13:54
 ;;21.0;VA FileMan;**12**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"OPT",405,20)
 ;;=D 5^DDXP
 ;;^UTILITY(U,$J,"OPT",405,"U")
 ;;=PRINT FORMAT DOCUMENTATION
 ;;^UTILITY(U,$J,"OPT",407,0)
 ;;=DI SORT COMPILE^Sort Template Compile/Uncompile^^R^^^^^^^^VA FILEMAN
 ;;^UTILITY(U,$J,"OPT",407,1,0)
 ;;=^^3^3^2930715^^
 ;;^UTILITY(U,$J,"OPT",407,1,1,0)
 ;;=This option allows the user to mark a Sort Template compiled or uncompiled.
 ;;^UTILITY(U,$J,"OPT",407,1,2,0)
 ;;=The actual routine compilation occurs when the template is used during
 ;;^UTILITY(U,$J,"OPT",407,1,3,0)
 ;;=FileMan Sort/Print.
 ;;^UTILITY(U,$J,"OPT",407,25)
 ;;=EN1^DIOZ
 ;;^UTILITY(U,$J,"OPT",407,"U")
 ;;=SORT TEMPLATE COMPILE/UNCOMPIL
 ;;^UTILITY(U,$J,"OPT",503,0)
 ;;=DDBROWSER^Browser^^R^^^^^^^^VA FILEMAN
 ;;^UTILITY(U,$J,"OPT",503,1,0)
 ;;=^^3^3^2940519^
 ;;^UTILITY(U,$J,"OPT",503,1,1,0)
 ;;=Prompts user to select file, word processing field and entry.
 ;;^UTILITY(U,$J,"OPT",503,1,2,0)
 ;;=The text is then displayed to the screen, allowing the user to
 ;;^UTILITY(U,$J,"OPT",503,1,3,0)
 ;;=navigate through the document.
 ;;^UTILITY(U,$J,"OPT",503,25)
 ;;=DDBR
 ;;^UTILITY(U,$J,"OPT",503,99.1)
 ;;=56123,39787
 ;;^UTILITY(U,$J,"OPT",503,"U")
 ;;=BROWSER
 ;;^UTILITY(U,$J,"OPT",509,0)
 ;;=DDS DELETE A FORM^Delete a Form^^R^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",509,1,0)
 ;;=^^1^1^2940630^^
 ;;^UTILITY(U,$J,"OPT",509,1,1,0)
 ;;=An option to delete a form.
 ;;^UTILITY(U,$J,"OPT",509,25)
 ;;=3^DDSOPT
 ;;^UTILITY(U,$J,"OPT",509,99.1)
 ;;=56123,39787
 ;;^UTILITY(U,$J,"OPT",509,"U")
 ;;=DELETE A FORM
 ;;^UTILITY(U,$J,"OPT",510,0)
 ;;=DDS PURGE UNUSED BLOCKS^Purge Unused Blocks^^R^^^^^^^^
 ;;^UTILITY(U,$J,"OPT",510,1,0)
 ;;=^^3^3^2940630^
 ;;^UTILITY(U,$J,"OPT",510,1,1,0)
 ;;=An option to delete blocks that aren't used on any forms.  This option
 ;;^UTILITY(U,$J,"OPT",510,1,2,0)
 ;;=prompts for file, and searches the Block File for all blocks that are
 ;;^UTILITY(U,$J,"OPT",510,1,3,0)
 ;;=associated with that file and that aren't used on any forms.
 ;;^UTILITY(U,$J,"OPT",510,25)
 ;;=4^DDSOPT
 ;;^UTILITY(U,$J,"OPT",510,99.1)
 ;;=56123,39787
 ;;^UTILITY(U,$J,"OPT",510,"U")
 ;;=PURGE UNUSED BLOCKS
 ;;^UTILITY(U,$J,"PKG",11,0)
 ;;=VA FILEMAN^DI^FM INIT

DIINIS
DIINIS ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PAC(PKG,VER) ; called from package init (DIFROM7 created this routine)
 ; PKG = $T(IXF) of the INIT routine.
 ; VER is an array that is contained in DIFROM from the INIT routine
 ;
 N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("DIINIS",$J)
 ;
 ; Site tracking updates only occur if run in a VA production primary domain
 ; account.
 I $G(^XMB("NETNAME"))'[".VA.GOV" Q
 Q:'$D(^%ZOSF("UCI"))  Q:'$D(^%ZOSF("PROD"))
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q
 ;
 S SERVER="S.A5CSTS@FORUM.VA.GOV"
 S PACKAGE=$P($P(PKG,";",3),U)
 S SITE=$G(^XMB("NETNAME"))
 S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown"
 D  ; check if ok to use kernel functions
 .S X="XLFDT" X ^%ZOSF("TEST") I $T D  Q
 ..S NOW=$$HTFM^XLFDT($H)
 ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3)
 ..S START=$$FMTE^XLFDT(START)
 ..S DATE=NOW\1
 ..S NOW=$$FMTE^XLFDT(NOW)
 .D NOW^%DTC S NOW=%,DATE=X
 .S RUN="" ; don't bother to compute
 .S Y=START D DD^%DT S START=Y
 .S Y=NOW D DD^%DT S NOW=Y
 ;
 ; Message for server
 S ^TMP("DIINIS",$J,1,0)="PACKAGE INSTALL"
 S ^TMP("DIINIS",$J,2,0)="SITE: "_SITE
 S ^TMP("DIINIS",$J,3,0)="PACKAGE: "_PACKAGE
 S ^TMP("DIINIS",$J,4,0)="VERSION: "_VER
 S ^TMP("DIINIS",$J,5,0)="Start time: "_START
 S ^TMP("DIINIS",$J,6,0)="Completion time: "_NOW
 S ^TMP("DIINIS",$J,7,0)="Run time: "_RUN
 S ^TMP("DIINIS",$J,8,0)="DATE: "_DATE
 ;
 ; Data is sent to server on FORUM - S.A5CSTS
 S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""DIINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION"
 D ^XMD
 K ^TMP("DIINIS",$J)
 Q

DIINIT
DIINIT ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S DIOVRD=1,U="^",DIFQ=0,DIFROM="21.0" W !,"This version (#21.0) of 'DIINIT' was created on 22-DEC-1994"
 W !?9,"(at FILEMAN 21 DEVELOPMENT AREA, by VA FileMan V.21.0V03)",!
 I $D(^DD("VERSION")),^("VERSION")'<21 G GO
 ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^DIINIT"_$E("5",DIFRIR) D @DIFRRTN
 W:0 !,"I AM GOING TO SET UP THE FOLLOWING FILE:" F I=1:2:0 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="21.0" D PKG:'$D(DIFROM(0)),^DIINIT1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^DIINIT2,^DIINIT3
 L  S DUZ=DIDUZ W:0 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 I DIFROM F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 I DIFROM,$D(^%ZTSK) S X="DIINIS" X ^%ZOSF("TEST") D:$T PAC^DIINIS($T(IXF),.DIFROM)
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^DIINIT2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W $C(7),!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;VA FILEMAN^DI;3

DIINIT1
DIINIT1 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK ;I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 F X="KEY","OPT" D W Q:'$D(DIFQ)
 ;Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^DIINI" F R=1:1:10 D @(DN_$$B36(R)) W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 Q
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;FORM
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)

DIINIT2
DIINIT2 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R=""  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

DIINIT3
DIINIT3 ; ;6/20/96  13:54
 ;;21.0;VA FileMan;**12**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X=""  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^DIINIT4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT")&(N'="PKG") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D
 .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
 .Q
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 I N="DIST(.403," D
 .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA)
 .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q
 .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled"
 .Q
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D
 .N X S X=0
 .F  S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X)
 .Q
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D
 .N X S X=0
 .F  S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X)
 .Q
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q
KAD(D0) N D1,X
 S X=0 F  S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0  S D1=0 F  S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0  K ^DIC(19,"AD",X,D0,D1)
 Q

DIINIT4
DIINIT4 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

DIINIT5
DIINIT5 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:0 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;VA FILEMAN^DI

DIIS
DIIS ;SFISC/GFT-DELETE THIS LINE AND SAVE AS '%ZIS' IF YOU DON'T HAVE A '%ZIS' ROUTINE ;11:04 AM  18 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
%ZIS ;
 I $D(IOP)#2 S IO=$I G PARAMS
 S IO=$I ;READ "DEVICE: ",IO ;INSERT DEVICE SELECTION HERE
PARAMS S IOM=80,IOSL=24,IOF="#",IOPAR="",POP=0,ION=$P(IO,";"),IOT="TRM"
 ;
 ; DIISS uses the variable IOST to determine what to set the screen
 ; handling variables to.  (See routine DIISS.)  DIISS currently
 ; looks for values of IOST equal to C-VT220 and C-VT320.  If it
 ; equals anything else, the IO variables default to the codes for
 ; C-VT100 terminals.
 ;
 ; The variable IOXY contains the code to position the cursor at
 ; column position DX and row position DY.  Unmodified, this
 ; routine sets IOXY to the code for VT100, VT220, and VT320
 ; terminals.
 ;
 S IOST="C-VT100"
 S IOXY="W $C(27,91)_(DY+1)_$C(59)_(DX+1)_$C(72)"
 Q

DIISS
DIISS ;SFISC/MKO-SAVE AS %ZISS IF STANDALONE FILEMAN ;01:39 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
%ZISS ;SFISC/MKO-RETURN SCREEN HANDLING IO VARIABLES ;
 ;
 ; This routine is for standalone FileMan sites that want to use
 ; FileMan's screen-oriented utilities.  It must be saved as %ZISS
 ; in the manager account.  There are four entry points:
 ;
 ;   ENDR  - returns the IO variables required for screen handling
 ;   KILL  - kills the IO variables set by ENDR
 ;   GSET  - returns the IO variables required to draw lines
 ;   GKILL - kills the IO variables set by GSET
 ;
 ; The input variable to all of these entry points is
 ;
 ;   IOST  - the terminal type name (e.g., C-VT100)
 ;
 ; The terminal types supported by this routine are C-VT100,
 ; C-VT220, and C-VT320.  To support another terminal
 ; type, modify the highlighted line in subroutine GETT, and create
 ; new subroutines that sets the IO variables appropriately.
 ;
 ; Also note that %ZIS must return in IOXY the code to position the
 ; cursor at column DX and row DY.
 ;
GETT ;Based on value of IOST, returns DITT with values:
 ;  1 = C-VT100 (default)
 ;  2 = C-VT220 or C-VT320
 ;  3 = C-DATATREE
 S U="^",DIIOST=$TR(IOST," ","")
 ;
 ;******
 ;**  To recognize other terminal types, modify the following line of
 ;**  code and add new subroutines (e.g., 4 and G4 for C-QUME) that
 ;**  set the IO variables equal to the codes for that terminal type.
 ;******
 ;
 S DITT=$S("^C-VT220^C-VT320^"[(U_DIIOST_U):2,DIIOST="C-DATATREE":3,1:1)
 ;*****
 K DIIOST
 Q
ENDR ;Set screen handler IO variables
 N DITT
 D GETT,@DITT
 Q
GSET ;Set graphics variables
 N DITT
 D GETT,@("G"_DITT)
 Q
KILL ;Kill screen handler IO variables
 K IOCUU,IOCUD,IOCUF,IOCUB,IOPF1,IOPF2,IOPF3,IOPF4
 K IOFIND,IOINSERT,IOREMOVE,IOSELECT,IOPREVSC,IONEXTSC,IOHELP,IODO
 K IOKPAM,IOKPNM
 K IOKP0,IOKP1,IOKP2,IOKP3,IOKP4,IOKP5,IOKP6,IOKP7,IOKP8,IOKP9
 K IOMINUS,IOCOMMA,IOPERIOD,IOENTER
 K IOEDALL,IOEDEOP,IOELEOL,IOELALL
 K IOINHI,IOINLOW,IOINORM,IORVON,IORVOFF,IOUON,IOUOFF,IOSGR0
 K IORI,IOSTBM,IOIL,IODL,IOICH,IODCH
 K IOIRM1,IOIRM0,IOAWM0,IOAWM1
 Q
GKILL ;Kill graphics variables
 K IOG0,IOG1,IOBLC,IOBRC,IOTLC,IOTRC,IOHL,IOVL,IOLT,IOTT,IORT,IOBT,IOMT
 Q
1 ;VT100 codes
 S IOCUU=$C(27)_"[A"
 S IOCUD=$C(27)_"[B"
 S IOCUF=$C(27)_"[C"
 S IOCUB=$C(27)_"[D"
 S IOPF1=$C(27)_"OP"
 S IOPF2=$C(27)_"OQ"
 S IOPF3=$C(27)_"OR"
 S IOPF4=$C(27)_"OS"
 S IOFIND=$C(27)_"[1~"
 S IOINSERT=$C(27)_"[2~"
 S IOREMOVE=$C(27)_"[3~"
 S IOSELECT=$C(27)_"[4~"
 S IOPREVSC=$C(27)_"[5~"
 S IONEXTSC=$C(27)_"[6~"
 S IOHELP=$C(27)_"[28~"
 S IODO=$C(27)_"[29~"
 S IOKP0=$C(27)_"Op"
 S IOKP1=$C(27)_"Oq"
 S IOKP2=$C(27)_"Or"
 S IOKP3=$C(27)_"Os"
 S IOKP4=$C(27)_"Ot"
 S IOKP5=$C(27)_"Ou"
 S IOKP6=$C(27)_"Ov"
 S IOKP7=$C(27)_"Ow"
 S IOKP8=$C(27)_"Ox"
 S IOKP9=$C(27)_"Oy"
 S IOMINUS=$C(27)_"Om"
 S IOCOMMA=$C(27)_"Ol"
 S IOPERIOD=$C(27)_"On"
 S IOENTER=$C(27)_"OM"
 S IOEDEOP=$C(27)_"[J"
 S IOEDALL=$C(27)_"[2J"
 S IOELEOL=$C(27)_"[K"
 S IOELALL=$C(27)_"[2K"
 S IOAWM0=$C(27)_"[?7l"
 S IOAWM1=$C(27)_"[?7h"
 S IOINHI=$C(27)_"[1m"
 S IOINLOW=$C(27)_"[m"
 S IOINORM=$C(27)_"[m"
 S IOUON=$C(27)_"[4m"
 S IOUOFF=$C(27)_"[m"
 S IORVON=$C(27)_"[7m"
 S IORVOFF=$C(27)_"[m"
 S IOSGR0=$C(27)_"[m"
 S IORI=$C(27)_"M"
 S IOSTBM="$C(27,91)_+IOTM_"";""_+IOBM_""r"""
 S IOIL=$C(27)_"[L"
 S IODL=$C(27)_"[M"
 S IOICH=$C(27)_"[@"
 S IODCH=$C(27)_"[P"
 S IOIRM1=$C(27)_"[4h"
 S IOIRM0=$C(27)_"[4l"
 S IOKPAM=$C(27)_"="
 S IOKPNM=$C(27)_">"
 Q
G1 ;VT100 line drawing codes
 S IOG0=$C(27)_"(B"
 S IOG1=$C(27)_"(0"
 S IOBLC="m"
 S IOBRC="j"
 S IOTLC="l"
 S IOTRC="k"
 S IOHL="q"
 S IOVL="x"
 S IOLT="t"
 S IOTT="w"
 S IORT="u"
 S IOBT="v"
 S IOMT="n"
 Q
2 ;VT220 and VT320 codes
 ;The codes are the same as VT100 except for a few
 D 1
 S IOINLOW=$C(27)_"[22m"
 S IOUOFF=$C(27)_"[24m"
 S IORVOFF=$C(27)_"[27m"
 Q
G2 ;VT220 and VT320 line drawing codes
 ;The codes are the same as those for VT100s
 D G1
 Q
3 ;C-DATATREE codes
 S IOXY="W /C(DX,DY)"
 S IOCUU=$C(1)
 S IOCUD=$C(11)
 S IOCUF=$C(18)
 S IOCUB=$C(14)
 S IOPF1=$C(21)
 S IOPF2=$C(22)
 S IOPF3=$C(23)
 S IOPF4=$C(24)
 S IOEDALL=$C(12)
 S IOEDEOP=$C(255)_"EF"
 S IOELEOL=$C(255)_"EL"
 S IOELALL=""
 S IOAWM0=""
 S IOAWM1=""
 S IOINHI=$C(255)_"AB"
 S IOINLOW=$C(255)_"AA"
 S IOUON=$C(255)_"AC"
 S IOUOFF=$C(255)_"AA"
 S IORVON=$C(255)_"AE"
 S IORVOFF=$C(255)_"AA"
 S IOINORM=$C(255)_"AA"
 S IOSGR0=$C(255)_"AA"
 S IORI=""
 S IOSTBM=""
 S IOIL=""
 S IODL=""
 S IOICH=""
 S IODCH=""
 S IOIRM1=""
 S IOIRM0=""
 Q
G3 ;C-DATATREE line drawing codes
 S IOG0=""
 S IOG1=""
 S IOBLC=$C(192)
 S IOBRC=$C(217)
 S IOTLC=$C(218)
 S IOTRC=$C(191)
 S IOHL=$C(196)
 S IOVL=$C(179)
 S IOLT=$C(195)
 S IOTT=$C(194)
 S IORT=$C(180)
 S IOBT=$C(193)
 S IOMT=$C(197)
 Q

DIK
DIK ;SFISC/GFT,YJK,XAK-GATHER A FILE'S XREFS TO EXECUTE ;10/3/94  16:21
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'$D(@(DIK_"DA)"))  Q:$P($G(^DD($$GLO^DILIBF(DIK),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM)  Q:DA'>0
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D CHKS I $D(DIKZ1) N DIKIL S DIKIL=1 G @DIKGP
 S X=2 D DD G ^DIK1
 ;
DD1 D D,A Q
 ;
DD D DIKJ S DV=0 D D,A
E S DV=$O(^DD(DH,"SB",DV))
 I DV>0 S DU=$O(^(DV,0)) G E:'$D(^DD(DV,.01,0)),E:$P(^(0),U,2)["W" S DW=$P($P(^DD(DH,DU,0),U,4),";") S:+DW'=DW DW=""""_DW_"""" S DV(DH,DU)=DW,DV(DH,DU,0)=DV,DU(DV)="" D:$D(DIK0) CRT^DIKZ2 G E
 Q:$D(DIK0)
DH S DH=$O(DU(DH)) G:DH>0 DH:$D(DV(DH)),E
 F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0  D D,A
 S DH=DH(1),DU=1
DV I $O(^UTILITY("DIK",DIKJ,DH))>DH S DH=$O(DV(DH)) G DV:DH>0 Q
K K DV(DH) S DH=$O(DV(DH)) G K:DH>0 Q
 ;
DW I $O(^UTILITY("DIK",DIKJ,DH,DV,0))="" K ^UTILITY("DIK",DIKJ,DH,DV)
D S DV=$O(^DD(DH,"IX",DV)) Q:DV'>0  I '$D(^DD(DH,DV,0)) K ^DD(DH,"IX",DV) G D
 D 0
I F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) Q:DW'>0  I $D(^(DW,X)),"Q"'[^(X),$D(^(0)) S %=^(0) D INX
 G DW
INX I %["TRIGGER" S %=^(X),^UTILITY("DIK",DIKJ,DH,DV,DW)="D RCR",^(DW,0)=% Q
 I %["BULLETIN MESSAGE",$D(DIK(0)),DIK(0)["B" S %=$P("CREA^DELE",U,X)_"TE VALUE" W:$D(^(%)) !,"...('"_^(%)_"' BULLETIN WILL NOT BE TRIGGERED)..." Q
 S ^UTILITY("DIK",DIKJ,DH,DV,DW)=^(X) Q
A F DV=0:0 S DV=$O(^DD(DH,"AUDIT",DV)) Q:DV'>0  D A1
 Q
A1 D 0 S ^UTILITY("DIK",DIKJ,DH,DV,99)="S DIIX="_(4-X)_" D:$G(DIK(0))'[""A"" AUDIT" Q
0 ;
 S DW=$P(^DD(DH,DV,0),U,4),^UTILITY("DIK",DIKJ,DH,DV)=$P(DW,";",1),DW=$P(DW,";",2)
 S ^UTILITY("DIK",DIKJ,DH,DV,0)=$S(DW:"S X=$P(^(X),U,"_DW_")",1:"S X=$E(^(X),"_+$E(DW,2,9)_","_$P(DW,",",2)_")"),DW=0 Q
 ;
IX ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D CHKS I $D(DIKZ1) N DIKKS S DIKKS=1 G @DIKGP
 S X=2,DIKNM=1 D DD,1^DIK1
IX1 ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 I '$D(DIKNM) D CHKS I $D(DIKZ1) N DIKST S DIKST=1 G @DIKGP
 S X=1 D DD,1^DIK1 G Q
 ;
IXALL ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D CHKS I $D(DIKZ1) N DIKSAT S DIKSAT=1,DA=0 G @DIKGP
 S (DA,DCNT)=0,X=1 D DD,CNT^DIK1 G Q
 ;
EN ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D N G:'$D(DH)!'$D(DA) Q
 S DIKNM=1,X=2 D PR,1^DIK1
 ;
EN1 ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D @$S('$D(DIKNM):"N",1:"DIKJ") G:'$D(DH)!'$D(DA) Q
 S X=1 D PR,1^DIK1 G Q
 ;
ENALL ;
 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA
 D N G:'$D(DH) Q
 S (DA,DCNT)=0,X=1 D PR,CNT^DIK1 G Q
 ;
N Q:'$D(DIK)!'$D(DIK(1))!'$D(@(DIK_"0)"))  D DIKJ S DIKND=$P(DIK(1),U)
 I '$D(^DD(DH,"IX",DIKND)) K DH Q
 I $P(DIK(1),U,2)="" S A1=1 F %=0:0 S %=$O(^DD(DH,DIKND,1,%)) Q:+%'>0  S DIKNX(A1)=%,A1=A1+1
 E  F A1=1:1 S DIKNX(A1)=$P(DIK(1),U,A1+1) I DIKNX(A1)="" K DIKNX(A1) Q
 K A1,% Q
 ;
PR S DV=DIKND I '$D(^DD(DH,"IX",DV)),'$D(^DD(DH,"AUDIT",DV)) Q
 D 0 S DIKZ1=1 D CK K DIKZ1
 D:$D(^DD(DH,"AUDIT",DV)) A1 S DU=1 Q
 ;
CK Q:'$D(DIKNX(DIKZ1))
 F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) Q:DW'>0  I $D(^(DW,0)),(DW=DIKNX(DIKZ1))!($P(^(0),U,2)=DIKNX(DIKZ1)),$D(^(X)),"Q"'[^(X) S %=^(0) D INX
 S DIKZ1=DIKZ1+1 G CK
 ;
FREE(X) N V S V=$G(^UTILITY("DIK",X)) I 'V Q 1
 Q $H-1>V
 ;
DIKJ F DIKJ=$J:.01 I $$FREE(DIKJ) K ^UTILITY("DIK",DIKJ) S ^UTILITY("DIK",DIKJ)=$H Q
INT K DIKS,DIN,DH,DU,DV,DW S U="^",DH=+$P(@(DIK_"0)"),U,2),DH(1)=DH Q
CHKS ;
 I '$D(@(DIK_"0)"))#2 S DIKZ1=1,DIKGP="Q^DIK1" Q
 S DIKZ1=+$P(^(0),"^",2) I DIKZ1,$D(^DD(DIKZ1,0,"DIK")),$$ROUEXIST^DILIBF(^("DIK")) S DIKGP="^"_^DD(DIKZ1,0,"DIK") Q
 K DIKZ1 Q
 ;
Q K DIKND,DIKNX,DIKZ1,DIKNM,DIAU,DIG,DIH,DIV,DIW,%,DH Q

DIK1
DIK1 ;SFISC/GFT-ACTUAL INDEXER ;8/24/94  13:15 [ 02/07/96  11:49 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D DI,K G Q:'$D(@(DIK_"0)"))
 S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA
 S ^(0)=$P(Y,U,1,2)_U_X_U_DH
Q K:$G(DIKJ) ^UTILITY("DIK",DIKJ)
 K DB(0),DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKGP Q
 ;
K S X="",Y=1 I $D(DIFKEP(DA))#2,DIK="^DIC(",$D(@(DIK_DA_",0,""GL"")")) S X=^("GL"),Y="^DIC("_DA_","
 I X'=Y K @(DIK_"DA)"),X,Y Q
 S X=DIK_"DA,",DH=@(X_"0)") K ^(0),^("%") S Y="""%""" F  S Y=$O(@(X_Y_")")) Q:$E(Y)'="%"  S Y=""""_Y_"""" K @(X_Y_")")
 S @(X_"0)")=DH K X,Y
 Q
 ;
3 I X>1,$D(^(X-1)) S X=X-1 Q
 S DV=1 F X=X:1 S X=X+DV,DV=DV+1 I $O(^(X))'>0 S DU=X-2,DV=1 Q
L S X=$O(^(DU)) Q:X>0  S DU=DU-DV,DV=DV+1 S:DU<0 DU=0 G L
 ;
DI S (DIC,DIN)=DIK,DH=DH(DU),DV=1 F  S DV=$O(DA(DV)) Q:DV'>0  S DU=DU+1
DIN S DV=0 F  S DV=$O(^UTILITY("DIK",DIKJ,DH,DV)) Q:DV=""  D R:DV-.01
DVA S DV=$O(DV(DH,DV)) I DV="" S DV=.01 D R:$D(^UTILITY("DIK",DIKJ,DH,DV)) Q
 S X=DIN_DA_","_DV(DH,DV) I @("'$D("_X_"))") G DVA
 S DU(DU)=DIN,DIN=X_",",DH(DU)=DH,DH=DV(DH,DV,0),DV(DU)=DV,DU=DU+1 F X=DU:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
 S DA(1)=DA,DA=0
DA S @("DA=$O("_DIN_"DA))") I DA>0 D DIN G DA
 S DU=DU-1,DIN=DU(DU),DH=DH(DU),DV=DV(DU),DA=DA(1) K DA(1) F X=2:1 G DVA:'$D(DA(X)) S DA(X-1)=DA(X) K DA(X)
 ;
R S X=^UTILITY("DIK",DIKJ,DH,DV),%=^(DV,0) I @("$D("_DIN_DA_",X))[0") Q
 X % Q:X']""  S DIKS=X,DW=0
XEC S DW=$O(^UTILITY("DIK",DIKJ,DH,DV,DW)) Q:DW=""  X ^(DW) S X=DIKS G XEC
 ;
RCR K Y,%RCR F %="DIKS","DIK","DW","DH","DIN","DU","DV","X" S %RCR(%)=""
 S %RCR="RR^DIK1",Y=^UTILITY("DIK",DIKJ,DH,DV,DW,0) G STORLIST^%RCR
 ;
RR X Y Q
 ;
AUDIT N %,%F,%T,%D,DIKF,DIKDA S %=DV N DV S DV=%
 S %F=DH,%=DU I $D(^DD(%F,0,"UP")) F %=1:1 Q:'$D(^DD(%F,0,"UP"))  S %D=%F,%F=^("UP"),DV(%)=$O(^DD(%F,"SB",%D,0)) S:DV(%)="" DV(%)=-1
 S DIKDA="",DIKF="" F %=%-1:-1:1 S DIKDA=DIKDA_DA(%)_",",DIKF=DIKF_DV(%)_","
 I $D(^DD(DH,DV,"AX")) X ^("AX") I '$T Q
 G SET:$D(DIAU(DH,DV,DIKDA_DA))
 D ADD^DIET S DIAU(DH,DV,DIKDA_DA)="^DIA("_%F_","_+Y_",",^DIA(%F,%D,0)=DIKDA_DA_U_%T_U_DIKF_DV_U_DUZ,^DIA(%F,"B",DIKDA_DA,%D)=""
SET N C S (%F,C)=$P(^DD(DH,DV,0),U,2),Y=X D Y^DIQ S @(DIAU(DH,DV,DIKDA_DA)_"DIIX)")=Y
 I %F["P"!(%F["V")!(%F["S") S ^(DIIX+.1)=X_U_%F
 Q
 ;
1 ;
 N DIKLK
 S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) G Q
 ;
CNT ;
 N DIKLK,DIKLAST S DIKLAST=$S(DA:DA,1:"")
 S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L @("+"_DIKLK)
C I @("$O("_DIK_"DA))'>0") S ^(0)=$P(@(DIK_"0)"),U,1,2)_U_DIKLAST_U_DCNT K DCNT L @("-"_DIKLK) G Q
 S DA=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DIKLAST=DA,DU=1,DCNT=DCNT+1 S:DA="" DA=-1 D:(DCNT#100=0) WR D DI K DB(0) G C
WR I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO="" Q
 I '$D(ZTQUEUED) W "."   ;IHS/MFD added I statement and moved Q down
 Q

DIKWIC
DIKWIC ; KWIC ROUTINE FOR FILE MANAGER ; [ 03/27/86  4:03 PM ]
S N SWB,OSTATE,STATE,LLEN,C,D,I,J,WF,WS,WD,WD2,WL,END,Q
 S D=%,L=X D TOKENIZE S I="" F J=0:0 S I=$O(WT(I)) Q:I=""  I ^DD("KWIC")'[("^"_I_"^") S @D=""
 G QUIT
K N SWB,OSTATE,STATE,LLEN,C,D,I,J,WF,WS,WD,WD2,WL,END,Q
 S D=%,L=X D TOKENIZE S I="" F J=0:0 S I=$O(WT(I)) Q:I=""  I ^DD("KWIC")'[("^"_I_"^") K:'($D(@D)\10) @D
QUIT K L,WT,I,J Q
TOKENIZE ; CONVERT INPUT LINE TO TOKENS ; [ 03/20/86  12:44 PM ]
 K WT
 D CONVERT
 K SWB,OSTATE,STATE,LLEN,C,I,J,WF,WS,WD,WD2,WL,END,Q
 Q
 ;
CONVERT ; DO ACTUAL CONVERSION
 S SWB="",STATE="SKIP",I=0,LLEN=$L(L)
CHLOOP S I=I+1
 I I>LLEN S END=1 D:STATE="SCAN" ENDWORD Q
 S C=$E(L,I)
 S OSTATE=STATE
 I OSTATE="SKIP",C'?1P S STATE="SCAN",WS=I
 I OSTATE="SCAN",C?1P,C'="-",C'="'" S END=0 D ENDWORD S STATE="SKIP"
 G CHLOOP
ENDWORD S WL=I-WS,WD=$E(L,WS,I-1)
 I WL=1 S SWB=SWB_WD I END S WD=SWB D STOREWD
 I WL>1 D STOREWD I SWB'="" S WD=SWB,SWB="" D STOREWD
 Q
STOREWD ;
REMQT S J=$F(WD,"'") I J>0 S WD=$E(WD,1,J-2)_$E(WD,J,255) G REMQT
 I WD'["-" D STOREWD2 Q
 S WD2="" F J=1:1 S WF=$P(WD,"-",J) Q:WF=""  Q:$L(WF)>2  S WD2=WD2_WF
 I WF="" S WD=WD2 D STOREWD2 Q
 S WD2=WD F J=1:1 S WF=$P(WD2,"-",J) Q:WF=""  S WD=WF D STOREWD2
 Q
STOREWD2 ;
 Q:(WD?1N.E)!(^DD("KWIC")[("^"_WD_"^"))
 Q:$L(WD)=2&("^IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"[("^"_WD_"^"))
 Q:WD?1N.E
 S WT(WD)=""
 Q

DIKZ
DIKZ ;SFISC/XAK-XREF COMPILER ;01:03 PM  7 Mar 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) Q
EN1 N DIKJ,%X D:'$D(DISYS) OS^DII
 I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
 S U="^" S:'$G(DTIME) DTIME=300
 D SIZ^DIPZ0(8036) G:$D(DTOUT)!($D(DUOUT))!('X) Q1 S DMAX=X
FILE K DIC S DMAX=X,DIC="^DIC(",DIC(0)="AEQ" D ^DIC G Q1:Y'>0 N DIPZ S DIPZ=+Y
 D RNM^DIPZ0(8036) G:$D(DTOUT)!($D(DUOUT))!(X="") Q1 S DNM=X
 W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) Q1
 S X=DNM,Y=DIPZ K DIPZ
EN ;
 S Y(1)=$$EZBLD^DIALOG(8036),Y(3)=Y D BLD^DIALOG(8024,.Y,"","DIR") W:'$G(DIKZS) !!,DIR,! K Y(1),Y(3)
 K ^UTILITY($J),^UTILITY("DIK",$J) N DIK,DIFILENO
 S DNM=X,(DH,DIFILENO)=+Y I $D(^DIC(+Y,0,"GL")) S DIK2=^("GL")
 I '$D(DIK2)!(DMAX<2400) G Q
 S X=DH D A^DIU21,WAIT^DICD:'$G(DIKZS),DT^DICRW,OS^DII:'$D(DISYS) S (DIKA,A)=1,(DRN,DIKZQ,T)=0
 S DIKGO="^"_DNM_1,DMAX=DMAX-100,DIK=DIK2,X=2,DIKVR="DIKILL"
 D NEWR S ^UTILITY($J,0,3)=" S DIKZK=2" D ^DIKZ0 G:DIKZQ Q D RTE
 S (X,DIKA,A)=1,DIKVR="DISET",DIK=DIK2
 D Q2,NEWR S ^UTILITY($J,0,3)=" S DIKZK=1",DIKGO=DIKGO_",^"_DNM_DRN
 D ^DIKZ0 G:DIKZQ Q D RTE,Q2,^DIKZ1
 S:'DIKZQ ^DD(DIFILENO,0,"DIKOLD")=DNM
Q I DIKZQ S X=DH(1) D A^DIU21
Q1 K DH,X,Y,DIK4,DIKQ,DIKC,T,DV,DIK8,DU,DW,DW1,DIKGO,DRN,DNM,DTOUT,DIRUT,DIROUT,DUOUT,DIC,A,%,%H,%Y
 K DIKVR,DIK6,DIKA,DIKR,DMAX,DIK2,DIKCT,DIK1,DIK0,^UTILITY($J),^("DIK"),DIK,DIKZQ,DIKZZ,DIKZZ1,DIKZOVFL
Q2 K DIKRT,DIKLW,DIKL2
 Q
SV S DNM(1)=DNM_DRN
 F DIKR=0:0 S DIKR=$O(^UTILITY($J,DIKR)) Q:DIKR'>0  S %=^(DIKR) K ^(DIKR) D SAVE:T+$L(%)>DMAX S ^UTILITY($J,0,DIKR)=%,T=T+$L(%)+2
SAVE I $D(DIKLW),'DIKR S ^UTILITY($J,0,997)=" G:'$D(DIKLM) "_$C(64+DIKCT)_$S(DNM_DRN'=DNM(1):"^"_DNM(1),1:"")_" Q:$D("_DIKVR_")"
 I $D(DIKLW),DIKR S ^UTILITY($J,0,998)=" G ^"_DNM_(DRN+1)
 S ^UTILITY($J,0,999)="END "_$S($D(DIKRT)&'DIKR:"Q",1:"G "_$S(DIKR&($D(DIKLW)):"END",1:"")_U_DNM_(DRN+1))
 N X,DIR S X=DNM_DRN X ^DD("OS",DISYS,"ZS") S X(1)=X D BLD^DIALOG(8025,.X,"","DIR") W:'$G(DIKZS) !,DIR S:$G(DIKZRLA)]"" @DIKZRLA@(DNM_DRN)="",DIKZRLAF=1
 D NEWR:'$D(DIKRT)!(T+$L(%)>DMAX) Q:DIKZQ  S ^DD(DH,0,"DIK")=DNM K DIKL2
 Q
NEWR ;
 I '$D(DIKRT)&(T+$L(%)>DMAX) S DIKZDH=+$P(^UTILITY($J,0,1),"#",2)
 K ^UTILITY($J,0) S DIKR=4,T=0,DRN=DRN+1 I $L(DNM_DRN)>8 W:'$G(DIKZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIKZRLA)]"" DIKZRLAF=0 S DIKZQ=1 Q
 S ^UTILITY($J,0,1)=DNM_DRN_" ; COMPILED XREF FOR FILE #"_$S($D(DIKZDH):DIKZDH,1:DH)_" ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; "
 K DIKZDH Q
RTE ;
 F DIK4=0:0 S DIK4=$O(DIK(X,DIK4)) Q:DIK4'>0  S DIKQ=DIK4,DH=2 F DIK6=0:0 S DIK6=^DD(DIKQ,0,"UP") Q:DIK6'>0!(^("UP")=DH(1))  D RTE1
 S DIKRT=1,A=A-1,DH=DH(1) G SV
 ;
RTE1 ;
 I DIK(X,DIK6)[$P(DIK(X,DIKQ),",") S DIK(X,DIK6)=DIK(X,DIK6)_","_$P(DIK(X,DIKQ),",",DH,999),DIKQ=DIK6,DH=DH+1 Q
 S DIK(X,DIK6)=DIK(X,DIK6)_","_DIK(X,DIKQ),DIKQ=DIK6
 Q
 ;
EN2(Y,DIKZFLGS,X,DMAX,DIKZRLA,DIKZZMSG) ;Silent or Talking with parameter passing
 ;and optionally return list of routines built and if successful
 ;FILE#,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY
 ;Y=FILE NUMBER (required)
 ;FLAGS="T"alk (optional)
 ;X=ROUTINE NAME (required)
 ;DMAX=ROUTINE SIZE (optional)
 ;DIKZRLA=ROUTINE LIST ARRAY, by value (optional)
 ;DIKZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
 ;*
 ;DIKZS will be used to indicate "silent" if set to 1
 ;Write statements are made conditional, if not "silent"
 ;*
 N DIKZS,DNM,DIQUIET,DIKZRIEN,DIKZRLAZ,%X,DIKJ,DIR,DIKZRLAF,DK1
 N DIK,DIC,%I,DICS
 S DIKZS=$G(DIKZFLGS)'["T"
 S:DIKZS DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D
 .N Y,DIKZFLGS,X,DMAX,DIKZRLA,DIKZS
 .D INIZE^DIEFU
 I $G(Y)'>0 D BLD^DIALOG(1700,"File Number missing or invalid") G EN2E
 I '$D(^DD(Y,0)) D BLD^DIALOG(1700,"File Number: "_Y_" Invalid") G EN2E
 I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing") G EN2E
 I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E
 I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E
 S DIKZRLA=$G(DIKZRLA,"DIKZRLAZ"),DIKZRIEN=Y
 S:DIKZRLA="" DIKZRLA="DIKZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU")
 S DIKZRLAF=""
 K @DIKZRLA
 D EN
 G:'DIKZS!(DIKZRLAF) EN2E
 D BLD^DIALOG(1700,"Compiling Cross-references (FILE#:"_DIKZRIEN_")"_$S(DIKZRLAF=0:", routine name too long",1:""))
EN2E I 'DIKZS D MSG^DIALOG() Q
 I $G(DIKZZMSG)]"" D CALLOUT^DIEFU(DIKZZMSG)
 Q
 ;
 ;DIALOG #101    'only those with programmer's access'
 ;       #820    'no way to save routines on the system'
 ;       #8020   'Should the compilation run now?'
 ;       #8024   'Compiling template name Input template of file n'
 ;       #8036   'Cross-References'
 ;       #8025   'Routine filed'
 ;       #1503   'routine name is too long...'

DIKZ0
DIKZ0 ;SFISC/XAK-XREF COMPILER ;12/12/94  14:54
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIK0=" I X'=""""" D DD^DIK,A,SD Q:DIKZQ
RET I $D(DK1) S A=A+1,DIKA=1,DH=0 F  S DH=$O(DK1(DH)) Q:DH'>0  D E^DIK
 S:DH="" DH=-1 I $D(DK1) K DK1 D SD Q:DIKZQ  G RET
 Q
SD F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0  S:$D(^DD(DH,"SB")) DK1(DH)="" D DD1^DIK,0 Q:DIKZQ  S:$D(^DD(DH,"IX")) DIK(X,DH)="A1^"_DNM_DRN K:'$D(^("IX")) DIK(X,DH) K DU(DH)
 Q
0 ;
 D SV^DIKZ Q:DIKZQ  S DIK1=""
 I $D(DIKA) S DIK1=" S DA("_A_")=DA"_$S(A=1:"",1:"("_(A-1)_")")
 F DIKL2=A-1:-1:1 S DIK1=DIK1_" S DA("_DIKL2_")=0"
 S ^UTILITY($J,DIKR+1)=DIK1_" S DA=0",DIKR=DIKR+2,^(DIKR)="A1 ;"
 K DIKA D ^DIKZ2 S DIKLW=1
 S DIKR=DIKR+1,DIK=DIK2_DIK8(DH),^UTILITY($J,DIKR)=A_" ;",DIKR=DIKR+1
A ;
 F DIKQ=0:0 S DIKQ=$O(^UTILITY("DIK",$J,DH,DIKQ)) Q:DIKQ'>0  S %=^(DIKQ) S:+%'=% %=""""_%_"""" D PUT
 K ^UTILITY("DIK",$J),DIK6
 Q
PUT I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ("_%_")=$G("_DIK_"DA,"_%_"))",DIK6(%)=""
 S DIKR=DIKR+1,(DIK6,^UTILITY($J,DIKR))=" "_$P(^UTILITY("DIK",$J,DH,DIKQ,0),"^(X)")_"DIKZ("_%_")"_$P(^(0),"^(X)",2,9)
 F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) Q:DIKC'>0  S %=^(DIKC) S:$O(^(0))'=DIKC DIKR=DIKR+1,^UTILITY($J,DIKR)=DIK6 D CRF
 S DIKR=DIKR+1 Q
 ;
CRF S DIKR=DIKR+1
 I %["Q:"!(%[" Q") S ^UTILITY($J,DIKR)=DIK0_" X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")" Q
 I %["D RCR" S ^UTILITY($J,DIKR)=DIK0_" D",DIKR=DIKR+2,^(DIKR-1)=" .N DIK,DIV,DIU,DIN",^UTILITY($J,DIKR)=" ."_^UTILITY("DIK",$J,DH,DIKQ,DIKC,0) Q
 I %["S XMB=" S ^UTILITY($J,DIKR)=DIK0_",$D(DIK(0)),DIK(0)[""B"" S DIKZR="_DIKC_",DIKZZ="_DIKQ_" D BUL^"_DNM,DIKR=DIKR+1,^UTILITY($J,DIKR)=DIK0_",'$D(DIKOZ) "_$S($L(%)<225:%,1:"X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")") Q
 S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_DH_",DV="_DIKQ_",DU="_A_" ",1:"")_%_$S(%[" AUDIT":"^DIK1",1:"")
 Q

DIKZ1
DIKZ1 ;SFISC/XAK-XREF COMPILER ;04:27 PM  2 Feb 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NEWR ;
 K ^UTILITY($J) S DRN=""
 S ^UTILITY($J,0,1)=DNM_" ; DRIVER FOR COMPILED XREFS FOR FILE #"_DH(1)_" ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; "
 S ^UTILITY($J,0,3)=" N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY"
 S ^UTILITY($J,0,4)=" S DIKLK=DIK_DA_"")"" L @(""+""_DIKLK) D DI L @(""-""_DIKLK) G Q"
 S ^(5)="DI S DIKM1=0,DIKUM=0,DA(0)="""",DV=0 F  S DV=$O(DA(DV)) Q:DV'>0  S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)"
 S ^(6)=" S:DV="""" DV=-1 S DH(1)="_DH(1)_",DIKUP=DA"
 S ^(7)=" I $D(DIKKS) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S DA=DIKUP D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q"
 S ^(8)=" I $D(DIKIL) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q"
 S ^(9)=" I $D(DIKST) D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET D DA Q"
 S ^(10)=" I $D(DIKSAT) D SET1 D DA Q"
 S ^(11)=" Q"
 S ^(12)="DA K DA F DV=1:1 Q:'$D(DIKUP(DV))  S DA(DV)=DIKUP(DV)"
 S ^(13)=" S DA=DIKUP Q"
 S ^(14)="SET1 S (DA,DCNT)=0"
 S ^(15)=" S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK["","":DU_"")"",1:DU) L @(""+""_DIKLK)"
 S ^(16)="C I @(""$O(""_DIK_""DA))'>0"") S DA=$$C1(DA),^(0)=$P(@(DIK_""0)""),U,1,2)_U_DA_U_DCNT K DCNT L @(""-""_DIKLK) Q"
 S ^(17)=" S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"""" S DU=1,DCNT=DCNT+1 S:DA="""" (DIKY,DA)=-1 D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C"
 S ^(18)=" Q"
 S ^(19)="C1(A) Q:$P($G(@(DIK_""A,0)"")),U)]"""" A"
 S ^(20)=" F  S @(""A=+$O(""_DIK_""A),-1)"") Q:$P($G(@(DIK_""A,0)"")),U)]""""!(A'>0)"
 S ^(21)=" Q A"
 S ^(22)="KILL S DIKILL=1,DIKZK=2",DIKR=22,X=2 D SUB
 S DIKR=DIKR+1,^(DIKR)=" Q"
 S DIKR=DIKR+1,^(DIKR)="SET S DISET=1,DIKZK=1",X=1 D SUB
 F DIK8=1:1 S DIKRT=$T(TEXT+DIK8) Q:DIKRT=""  S ^(DIKR+DIK8)=$E(DIKRT,4,999)
 S (DRN,DIKR)="",T=0
 F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ'>0  S %=^(DIKZZ),T=T+$L(%) I T>DMAX S DIKZOVFL=1 D OVFL^DIKZ11 Q
 S T=0 I $D(DIKZOVFL) D SAVE^DIKZ K ^UTILITY($J,0) F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,"OVFL",DIKZZ)) Q:DIKZZ'>0  S %=^(DIKZZ) S ^UTILITY($J,0,DIKZZ)=%
 I $D(DIKZOVFL) S DRN=0 K ^UTILITY($J,"OVFL")
 G SAVE^DIKZ
 ;
SUB F DIK8=0:0 S DIK8=$O(DIK(X,DIK8)) Q:DIK8'>0  S DIKR=DIKR+1,^(DIKR)=" I DIKZ1="_DIK8_","_$P(DIK2(DIK8),",",4)_" S "_$P(DIK2(DIK8),",",3)_" D "_DIK(X,DIK8)_" Q"
 Q
TEXT ;;
 ;; Q
 ;;KIL1 K @(DIK_"DA)") Q:'$D(^(0))
 ;; S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA
 ;; S ^(0)=$P(Y,U,1,2)_U_X_U_DH
 ;; Q
 ;;Q K DIKGP,DIKZ1 Q
 ;; ;
 ;;3 I X>1,$D(^(X-1)) S X=X-1 Q
 ;; S DV=1 F X=X:1 S X=X+DV,DV=DV+1 I $O(^(X))'>0 S DU=X-2,DV=1 Q
 ;;L S X=$O(^(DU)) Q:X>0  S DU=DU-DV,DV=DV+1 S:DU<0 DU=0 G L
 ;; Q
 ;;BUL S DIKOZ=1,DIKZA=$P("CREA^DELE",U,DIKZK)_"TE VALUE"
 ;; I $D(^DD(DIKZ1,DIKZZ,1,DIKZR,DIKZA)) W "...(`",^(DIKZA),"` BULLETIN WILL NOT BE TRIGGERED) " Q

DIKZ11
DIKZ11 ;SFISC/DCM-XREF COMPILER ;9/3/93  13:44
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
OVFL ;
 S ^UTILITY($J,"OVFL",1)=DNM_0_" ; DRIVER FOR COMPILED XREFS FOR FILE !"_DH(1)_" (cont); "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; "
 S ^UTILITY($J,0,7)=" I $D(DIKKS) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S DA=DIKUP D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET"_U_DNM_0_" D DA Q"
 S ^UTILITY($J,0,9)=" I $D(DIKST) D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET"_U_DNM_0_" D DA Q"
 S ^UTILITY($J,0,17)=" S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"""" S DU=1,DCNT=DCNT+1 S:DA="""" (DIKY,DA)=-1 D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET"_U_DNM_0_" D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C"
 F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ=""  S %=^(DIKZZ) I $E(%,1,4)="SET " D OVFL1 Q
 Q
OVFL1 S DIKZZ1=4,^UTILITY($J,"OVFL",DIKZZ1)=% K ^UTILITY($J,0,DIKZZ)
 F  S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ=""  S %=^(DIKZZ) Q:$E(%,1,5)="KIL1 "  S DIKZZ1=DIKZZ1+1,^UTILITY($J,"OVFL",DIKZZ1)=% K ^UTILITY($J,0,DIKZZ)
 Q

DIKZ2
DIKZ2 ;SFISC/XAK-XREF COMPILER ;11/12/91  1:05 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIKR=DIKR+1
 S DIK1=" I $D("_DIKVR_") K DIKLM S:$D(DA("_A_")) DIKLM=1 G:$D(DA("_A_")) "_A
 F DIK4=A:-1:1 S DIK8=DIK4-1 Q:DIK8=0  S DIK1=DIK1_" S DA("_DIK4_")=DA("_DIK8_")"
 S ^UTILITY($J,DIKR)=DIK1_" S DA(1)=DA,DA=0 G @DIKM1"
 S DIKR=DIKR+1,DIKCT=0 I A>1 D DAR
 S ^UTILITY($J,DIKR)=A-1_" ;",DIKR=DIKR+1
 S DIKCT=DIKCT+1,DIKL2=A-1,DIK1=$C(64+DIKCT)_" S DA=$O("_DIK2_DIK8(DH)_"DA))"
 S ^UTILITY($J,DIKR)=DIK1_" I DA'>0 S DA=0 "_$S(DIKL2=0:"",1:"Q:DIKM1="_DIKL2_"  ")_"G "_$S(A'<2:$C(64+A-1),1:"END"),DIKR=DIKR+1
 K DIK6
 Q
CRT ;
 I '$D(^DD(DV,"IX")) K DU(DV) Q
 S DIK(X,DV)="",DIK4(DV)=DW,DIK2(DV)="DA("_A_"),,DIKM1="_A_",DIKUM'<"_A
 I A=1 S DIK8(DV)=$P(DIK2(DV),",",1,2)_DIK4(DV)_","
 S DIKQ=DH,DIKC=DV
 I $D(DIK2(DH)) S DIK8(DV)="" F DIK8=A:-1:1 S DIK8(DV)=DIK8(DV)_$P(DIK2(DIKC),",",1,2)_$S($D(DIK4(^DD(DIKC,0,"UP"))):DIK4(^("UP")),1:DIK4(DV))_"," S (DIKC,DH)=^("UP") Q:'$D(^DD(DH,0,"UP"))
 I A>2 S DIK8(DV)=$P(DIK8(DV),",",1)_","_$P(DIK8(DV),",",4)_","_$P(DIK8(DV),",",3)_","_$P(DIK8(DV),",",2)_","_$P(DIK8(DV),",",5,99)
 S DH=DIKQ
 Q
DAR ;
 S (DIKC,DIK1,%,DIKL2)=1,DIKQ=0
 F DIK8=A-1:-1:1 S DIKC=DIKC+2,DIKCT=DIKCT+1,DIK4=" S DA("_DIK8_")=$O("_DIK2_$P(DIK8(DH),",",1,DIKC)_"))" S:'$D(%) ^UTILITY($J,DIKR)=DIKL2_" ;",DIKR=DIKR+1,DIKL2=DIKL2+1 K % D DAR2 K DIK1
 Q
DAR2 ;
 S ^UTILITY($J,DIKR)=$C(64+DIKCT)_DIK4_" I DA("_DIK8_")'>0 S DA("_DIK8_")=0 "_$S($D(DIK6)&('$D(DIK1)):"Q:DIKM1="_DIKQ_"  ",1:"")_"G "_$S($D(DIK1):"END",1:$C(64+DIKCT-1)),DIKR=DIKR+1,DIKQ=DIKQ+1,DIK6=1
 Q

DIL
DIL ;SFISC/XAK-TURN PRINT FLDS INTO CODE ;11/4/92  10:27 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F DD=1:1 S W=$P(R,$C(126),DD) G Q:W="" S:DIWL DIWL=9 D DM I DIO S DN=-8,W=DIO,DIO=0 I W>1 S DIO=DM+2-W,W=$P(F,C,1,DIO)_$E(C,DIO>0)_"D 0^DIWW;X" D DM S DIWR(DIO)=DX,DIO=0
 ;
DM I DM G UP:$P(W,F,1)]"" S W=$P(W,F,2,999)
 I W[";Y" S DE="" D W:DG S I=+$P(W,";Y",2),DG=0,Y=DE_" F Y=0:0 Q:$Y>"_$S(I>0:I-2,1:"(IOSL"_(I-2)_")")_"  W !" S:I>0 M(DP)=I D PX S O=999
 G ^DIL1:'W,^DIL11:W?.NP1",".E,^DIL1:$P(W,";",1)'=+W K DPQ(DP,+W)
 D DE,^DIL0 G T:DU=DN I $P(X,U,2)["C" S DN=-2 G PX
 S DN=DU,Y=" S X=$G("_DI_C_DN_"))"_Y
PX ;
 I DHT G PX^DIPZ1:DHT<0 S ^UTILITY($J,DV)=$E(Y,2,999),Y="",DV=DV+1 Q
 S DX=DX+1 G PX:$D(^UTILITY($J,99,DX)) S ^(DX)=$E(Y,2,999)
 I DM S M=DX D DX
 S O=0
Q Q
 ;
DE S DE="" I W[";S" D W:DG S I=+$P(W,";S",2),DG=0 S:'I I=1 S M(DP)=M(DP)+I,DE=DE_" D T Q:'DN " F I=I:-1:1 S DE=DE_" D N"
 I $P(W,";C",2) S DIC=$P(W,";C",2) S:DIC<0 DIC=IOM+DIC+1 D W:DIC<DG S DG=DIC-1 I 1
 I DN=-4!$T S DE=DE_" D N:$X>"_DG_" Q:'DN "
 S DE=DE_" W ?"_DG Q
W ;
 D DIWR^DIL0:$D(DIWR)
A ;
 S M(DP)=M(DP)+1 I DHD,$D(V)>9 S I=$O(V(0)) S:I="" I=-1 F I=I:1:99 S Z="W !" D B
 K ^UTILITY("DIL",$J),V Q
B F V=-1:0 S V=$O(^UTILITY("DIL",$J,V)) Q:V=""  I $D(^(V,I)) S %=^($O(^(0))-I+99) D C,U:$L(Z)+$L(%)>245 S Z=Z_",?"_V_","""_%_""""
U S ^UTILITY($J,DHD)=Z,DHD=DHD+1,Z="W """"" Q
C I %?1" ".E S V=V+1,%=$E(%,2,999) G C
 Q
 ;
D ;
 D PX:DHT<1 S F(DM)=DX,R(DX)=DP(DM),R(DX,1)=M(DP(DM)),F=F_W_C,DM=DM+1,DIL=DIL+1,DD=DD-1 I DHT+1 S DX=$S('DHT:900,1:DX) D:DHT PX Q
 G DE^DIPZ1
 ;
UP D UN G DM
 ;
UNSTACK ;
 D UN Q:'DM  G UNSTACK
 ;
UN ;
 D DIWR^DIL0:$D(DIWR(DM))
 D:DHT<0 UP^DIPZ1 S O=999,DN=-8,DM=DM-1,DIL=DIL-1,DP=DP(DM),DX=$S(DM:F(DM),1:0),F=$P(F,C,1,DM)_$E(C,DM>0),DY=DY(DM),DI=DI(DM)
 I $D(DIL(DM)) S Y=" K J("_DIL0_"),I("_DIL0_")",DIL=DIL(DM),DIL0=DIL(DM,0) K DIL(DM) F X=DIL0:1 S %=X#100,V="I("_X_C_"0)",Y=Y_" S:$D("_V_") D"_%_"="_V I X=DIL G PX
 Q
 ;
O ;
 D DE,DN^DIL0
T ;
 G PX:'$D(^UTILITY($J,99,DX))!DIO,PX:$L(^(DX))+$L(Y)+O>240 S ^(DX)=^(DX)_Y Q
 ;
DX ;
 S Y=F(DM-1) D IF S ^(Y)=^UTILITY($J,99,Y)_$S($T:",^UTILITY($J,99,",1:" X ^UTILITY($J,99,")_M_")"
 I $T,$L(^UTILITY($J,99,Y))>99 F O=500:1 I '$D(^(O)) S ^(Y)=$E(^(Y),1,$L(^(Y))-1-$L(M))_O_")",F(DM-1)=O,^(O)="X ^UTILITY($J,99,"_M_")" Q
 Q
IF I ^UTILITY($J,99,Y)?.E1"^UTILITY($J,99,".N1")"
 Q

DIL0
DIL0 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;4/14/92  10:40 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D XDUY S %=$P(X,U,2) G WP:%["W",M:%["m",STATS^DIL1:$D(DCL(DP_U_+W)),N:W[";N"
 I W[";W" S Z=$D(DNP),DNP=1 D ^DILL K:'Z DNP S D1=$S(%["C":Y,1:$P(" S Y=",U,Y'?1" ".E)_Y_" S X=Y") D W S Y=Y_D1_" D ^DIWP" Q
 D ^DILL
DN ;
 I W[";X" S DE=$S(W[";C"!(W[";S"):DE,$A(Y)-32:" W ?0",1:"") I $L(DE)+$L(Y)>250 S %=Y,Y=DE,DE=% D PX^DIL S Y=DE Q
 I W[";X" S Y=DE_Y Q
 D H:DHD I DG+DLN>IOM,DG K ^UTILITY("DIL",$J,DG) S DG='%*DM*2+2,DE=$P(W,";C",2),DG=$S(DE>0:DE-1,DE<0:IOM+DE,DG+DLN'>IOM!(W[";W"):DG,DLN>IOM:0,1:IOM-DLN),DE=" D T Q:'DN  W ?"_DG D W^DIL,H:DHD
 S DG=2+DLN+DG Q:$D(DNP)  I $L(DE)+$L(Y)>250 S %=Y,Y=DE,DE=% D PX^DIL S Y=DE Q
 S Y=DE_Y Q
 ;
H S V=$P(X,U,1),Z=99,I=$P(W,";""",2) I I]"" S V=$P(I,"""",1)
HEAD Q:V=""  S I=$P(V," ",1) I $L(I)>DLN S DLN=$L(I)
XD S V=$P(V," ",2,99),D=$P(V," ",1) I D]"",$L(I)+$L(D)<DLN S I=I_" "_D G XD
 S ^UTILITY("DIL",$J,DG,Z)=$J(I,DRJ*DLN),V(Z)="",Z=Z-1 G HEAD
 ;
XDUY ;
 I '$D(^DD(DP,+W,0)) S X="",DU=0,Y=0 Q
 S X=^(0),DU=$P(X,U,4),Y=$P(DU,";",2),DU=$P(DU,";",1) I W[";T",$D(^(.1)) S X=^(.1)_U_$P(X,U,2,99)
 S:+DU'=DU DU=""""_DU_""""
 I Y S Y="$P(X,U,"_Y_")" Q
 I Y="" S Y="D"_DM Q
 S Y=$E(Y,2,9) S:$P(Y,",",2)=+Y Y=+Y S Y="$E(X,"_Y_")" Q
 ;
WR ;
 K DLN D W^DILL
W S DRJ=0,DIWL=DIWL+1 I '$D(DLN) S %=IOM-DG,DLN=$S(%>20:%,1:IOM)-2
 D DN S %=$P(DE,"W ?",2)+1,Y=DLN+%-1,DIO=2,%=" S DIWL="_%_",DIWR="_$S(IOM<Y:IOM,1:Y),Y=$P(DE," W ?",1)_% Q
 ;
WP S DN=%["L"_U D WR S DIO=3,Y=%_" D ^DIWP",X=F(DM-1) I DHT<0 G WP^DIPZ1
 I $D(^UTILITY($J,99,X)) S I=^(X) D WPX S ^UTILITY($J,99,X)=I Q
 ;S I=DX(X) D WPX S DX(X)=I Q
WPX ;
 S:DN I=^DD("FUNC",38,1)_" "_I
 I DE[" D T,N" S %=$F(I," D N:$X>") S:% I=$E(I,1,%-9)_$E(I,$F(I,"T",%),999) S I=$E(DE,2,999)_" "_I
 Q
 ;
M S D1=" S DICMX=""D "_$E("L",%'["w")_"^DIWP"" "_$P(X,U,5,99) D WR S Y=Y_D1 Q
 ;
N ;
 S DCL=DCL+1,D=",C="_DCL_" D D",DITTO(DCL)="",I=""
 I %["C" S X=X_" S Y=X"_D_" S X=Y",DXS="Y" G Z
 S Y=" S Y="_Y_D,DXS="Y"
Z D V^DILL G DN
 ;
DIWR ;
 G DIWR^DIPZ1:DHT I $D(DIWR(DM)),DX=DIWR(DM) S ^UTILITY($J,99,DX)="D A^DIWW" G K
 I $D(DIWR(DM)) S (DX,M)=DX+1,^UTILITY($J,99,DX)="D ^DIWW" D:DM DX^DIL G K
 D FI S ^(I)="D ^DIWW "_^UTILITY($J,99,I)
K K DIWR(DM) Q
FI F I=DM-1:-1:0 I $D(DIWR(I)) K DIWR(I) Q
 I I S I=F(I)
 E  F I=1:1 Q:'$D(^UTILITY($J,99,I+1))
 ;I $D(^UTILITY($J,99,I)) S ^(I)=^(I)_^(I)
 Q

DIL1
DIL1 ;SFISC/GFT-STATS, NUMBER FIELD, ON-THE-FLY ;11/4/92  10:39 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $A(W)=34 S Y="" F A9=0:0 S Y=Y_""""_$P(W,"""",2)_"""",W=$P(W,"""",3,99) Q:$A(W)'=34&($A(W)'=95)  S:$A(W)=95 Y=Y_$C(95),W=$P(W,"_",2,99)
 I  K A9 S Y=" W "_Y,DLN=0,X="",DRJ=0 D DE^DIL,W^DILL:W[";" G:W[";W" WR S %=$L(Y)-5 S:'DLN DLN=% S:DRJ Y=" W ?"_(DG+DLN-%)_Y D DN^DIL0 G T^DIL
 S:DN<0 O=999 S X="",DRJ=0 I W?1"0".E K DPQ(DP,0) S Y="D"_(DIL-DIL0),X=$S($D(^DD(DP,.001,0)):^(0),1:"NUMBER^^^^$L(X)>9") G 0:$D(DCL(DP_U_0)) D ^DILL G O^DIL
 S DN=$E(W,$L(W)),X=$P(W,";",1) K DLN
 S V=$S(X?.E1" W X K Y":8,X?.E1" W X K DIP":10,X?.E1" D DT K DIP":"11D",X?.E1" D DT K Y":"9D",1:0),X=$E(X,1,$L(X)-V)_" K DIP K:DN Y"
 I W[";N" S DCL=DCL+1,X=X_" S Y=X,C="_DCL_" D D S X=Y",DITTO(DCL)=""
 S Y=" "_X,X="^^^^"_X,%=DN,DN=-3
 I W[";m" D W S X="D "_$E("L",W'[";w")_"^DIWP",V=$F(Y,"D ^DIWP"),Y=$S(V:$E(Y,1,V-8)_X_$E(Y,V,999),1:" S DICMX="""_X_""""_Y) G T^DIL
 D CLC^DILL:V,W^DILL:'V
 S:'$D(DLN) DLN=9 I W[";W" D W S Y=Y_" D ^DIWP" G T^DIL
 G O^DIL:"+#&!*"'[%
 S X="^C"_V_"^^^"_$E(Y,2,999),W=-1_";"_$P(W,";",2,9),DCL(DP_U_-1)=%
0 D DE^DIL,STATS G T^DIL
 ;
W D DE^DIL,WR^DIL0 S Y=Y_" "_$E(X,5,999) Q
 ;
WR S D1=" S Y="_$P(Y,"W ",2,999),Y="" D W^DIL0
 F D1=D1," S X=Y D ^DIWP" S:$L(Y)+$L(D1)'>250 Y=Y_D1 I $F(Y,D1)-1'=$L(Y) D PX^DIL S Y=D1
 G T^DIL
 ;
STATS ;
 I DG<10!(DG>900) S DG=10 D DE^DIL I DE'["!" S DE=" W:$X>8 !"_DE
 S V=DP_U_+W,I=DCL(V),D=+I S:'D (D,DCL)=DCL+1,DCL(V)=D_I
 S DXS=$S(I["*":"C",I["#":"S",I["&":"A",I["+":"P",1:1),I=$P(X,U,2),V=I,%=":Y"_$S(I["C":"'?.""*""",Y["$E":"'?."" """,1:"]""""") I DXS S DSUM=" S"_%_" N("_D_")=N("_D_")+1",N(D)=0 G E
 G @DXS
 ;
C S CP(D)=""
S S Q(D)=0,L(D)=9999999999,H(D)=-L(D) I $P(I,"I",2) S DLN=+$P(I,"I",2)
P S N(D)=0
A S (S(D),DRJ)=0
 S DSUM=",C="_D_" D "_DXS_%
E I I["C" D V^DILL S Y=Y_" S Y=X"_DSUM,DXS=$S($D(^DD(DP,+W,9.02)):^(9.02),1:0) G UTIL
DILL S DXS=DSUM,Y=" S Y="_Y_DXS,I="",DXS="Y" D V^DILL
UTIL K DSUM S ^UTILITY($J,"T",DG)=DLN_U_D_U_DRJ_U_$P(X,U,2)_U_I
 I DXS?1E G DN^DIL0
 S ^(DG)=^(DG)_U_DXS,DN=^DD(DP,+W,9.01),DOP=$D(DNP),DNP="",DOP(1)=DLN,DOP(2)=X I 'DOP S V=$L(Y)+$L(DE) S:V<250 Y=DE_Y I V>249 S V=Y,Y=DE D PX^DIL S Y=V
LOOP S DE="",V=$P(DN,";"),W=$P(V,U,2),DN=$P(DN,";",2,99) G Q:V="",LOOP:$D(DCL(V))
 D PX^DIL,XDUY^DIL0,^DILL
 I $P(X,U,2)'["C" S Y=",X=$G("_DI_C_DU_"))"_$P(",Y=",U,Y'[" S Y=")_Y
 E  S Y=Y_" S Y=X"
 S (D,DCL)=DCL+1,S(D)=0,DCL(DP_U_+W)=D,Y=" S C="_D_Y_" D A" G LOOP
 ;
Q S DLN=DOP(1),X=DOP(2) K:'DOP DNP K DOP G DN^DIL0

DIL11
DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;11/20/92  09:28
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DOWN ;
 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_""""
 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_"))"
 G P:$P(^DD(DP,.01,0),U,2)["W"
 I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP))
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"))
 S Y=Y_" "
P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"")
 G S
R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ")
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
 G D^DIL
 ;
F ;
 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
 E  S DI=DI(DM)_","""_X_""",",DIL=DIL+101
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
 S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP
 S X=" "_$P($P(W,U,4,99),";",1)
 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
 S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=C_%_X
 I DHT=-1 D DREL^DIPZ1 G END
 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
END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1))
 Q

DIL2
DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;09:56 AM  7 Feb 1995
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D T:$D(^UTILITY($J,"T")) S:DIPT $P(^DIPT(DIPT,0),U,7)=DT S:$D(DIBT) $P(^DIBT(DIBT,0),U,7)=DT S:$G(DISV) $P(^DIBT(DISV,0),U,7)=DT
 F X=0:0 S X=$O(R(X)) Q:X=""  I X<500,$O(^UTILITY($J,99,X))>499 S DX=X
 S X=$S($D(DNP):"",$D(DIWR):" D ^DIWW",($G(DIAR)=4!($G(DIAR)=6)):" W "".""",1:" D T")_$S(DIWL:" K DIWF",1:"")_$S($D(CP):" D CP",1:"")_$P(" S DJ=DJ+1",U,$D(DIS)>9&(L!($D(DISTEMP))))_$S($D(DHIT):" X DHIT",1:"")
 I X'["D T" S X=X_" S DISTP=DISTP+1 D:'(DISTP#100) CSTP^DIO2"
 S:$D(DISV) X=X_" S ^DIBT("_DISV_",1,D0)="""""
 S:X]"" DX=DX+1,^UTILITY($J,99,DX)=$E(X,2,999)
 K DIOT S DW=2,(DQI,DV)=DHD,M=M(DP(0)),DL=DV?1"-".E
 I 'DV G HT:DV?.P1"[".E1"]",0:DV?1"W ".E,0:$G(DIFIXPT)=1,0:$G(IOST)?1"C".E S ^UTILITY($J,99,0)="Q" G G
 I $D(DIPZ) S ^UTILITY($J,1)=^UTILITY($J,1)_" X ^UTILITY($J,2) D HEAD"_^DIPT(DIPZ,"ROU")_^("LAST") G 0
 S X="",$P(X,"-",$S(IOM<244:IOM,1:244))="-"
 D O S ^UTILITY($J,DV)="W !,"""_X_""",!!",^(1)=^(1)_O
0 S ^UTILITY($J,99,0)="I DC["","""_$S(DIPT=.01:"!($Y>"_(DIOSL-5)_")",1:"")_" X ^UTILITY($J,1)"
G S DX(0)=^UTILITY($J,99,0) K ^UTILITY($J,0),DXIX
 I $D(DPP(0)) S DJ=DPP(0,"IX"),DPQ=$O(DPP(DPP(0)))]"",DJK=0 G ^DIO
 S DPQ=$P(DPP(1),U,4)["-"!($D(DPP(1,"CM"))&('$D(DPP(1,"PTRIX"))))
 F R=2:1:DPP S:'$D(DPP(R,U)) DPQ=1
 S:$P(DPP(1),U,5)[";L" DPQ=1
 S DJK=1 I DPQ S %=0 F R=1:1:DPP I +$G(DPP(R,"SER"))>% S %=+DPP(R,"SER"),DJK=R
 I $D(DPP(DJK,"IX")) S DJ=DPP(DJK,"IX") G ^DIO
 S DJ=DK_DK_U_1 I $O(DPP(DJK,-1))>0!$P(DPP(DJK),U,2) S DPQ=1
 S:'DPQ DPP(1,"IX")=""
 G ^DIO
 ;
O S O=" F DE="_DW_":1:"_DHD_" X ^UTILITY($J,DE)" Q
 ;
T ;
 F DG=-1:0 S DG=$O(^UTILITY($J,"T",DG)) Q:DG=""  S Z="""",I=$P(^(DG),U,6,99) I I]"" F W=2:1 Q:$P(I,Z,W,99)=""  S V=$P(I,Z,W) I V]"",$D(DCL(V)) S I=$P(I,Z,1,W-1)_+DCL(V)_$P(I,Z,W+1,99),W=W-1,^(DG)=$P(^(DG),U,1,5)_U_I
 Q
 ;
HT S DLP=DX,DCC=M,DV=DW,DNP(1)=DISMIN D INIT^DIP5 S DISMIN=DNP(1) K DNP(1)
 F %=0:0 S %=$O(^DIPT("B",$P($P(DHD,"[",2),"]",1),%)) G TT:%="" I $D(^DIPT(%,0)),$P(^(0),U,4)=""!($P(^(0),U,4)=DP) S $P(^(0),U,7)=DT Q
 I $D(^("ROU")),^("ROU")[U,'$D(^("DXS")),$D(^("IOM")),^("IOM")'>IOM S ^UTILITY($J,DV)="D "_^("ROU"),DV=DV+1 G EHT
 F V=0:0 S V=$O(^DIPT(%,"DXS",V)) Q:V'>0  F I=0:0 S I=$O(^DIPT(%,"DXS",V,I)) Q:I'>0  S R=^(I) D X S ^UTILITY($J,V,I)=R
 S DX=-1,DHD="^DIPT("_%_",""F"",DHT)" F DHT=0:0 S DHT=$O(@DHD) S:DHT="" DHT=-1 Q:DHT'>0  S R=^(DHT) D X D  D UNSTACK^DIL:DM
 . N DNP D ^DIL
 I $L(Y)>1 D PX^DIL
EHT S DX=DLP,DHD=DV-1,M=M(DP(0)) D O,OS^DII:'$D(DISYS) S DW=DV I $P(^DD("OS",DISYS,0),U,6) S O=" N X"_O
 I DL S M=M+1,DILIOSL=IOSL-M,^(1)="X DIOT "_^UTILITY($J,1)_" K DIOT(2)",DIOT="I DC?.N,$Y X DIOT(1)"_O,DIOT(1)="S DIOT(2)=1 F %=0:0 W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))",M=M+DCC G 0
 S M=DCC,^(1)=^UTILITY($J,1)_O
TT S DHD=$P(DQI,"]",2) G 0:DHD="" S DL=1 G HT
 ;
X S W=$F(R,"X DXS("),Y=+$E(R,W,999),X=+$E(R,$F(R,C,W),999) I W,X,Y S R=$E(R,1,W-5)_"^UTILITY($J,"_Y_C_X_$E(R,W+$L(X)+$L(Y)+1,999) G X

DILF
DILF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;6/7/94  10:47
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
CREF(X) G ENCREF^DIQGU
 ;
OREF(X) G ENOREF^DIQGU
 ;
FDA(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ;
 G LOADX^DIEF1
 ;
CLEAN ;
 G CLEAN^DIEFU
 ;
IENS(DIEFDA) ;
 G IENX^DIEFU
 ;
DA(DAIEN,DATARG) ;
 G DAX^DIEFU
 ;
DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ;
 G DTX^DIEFU
 ;
VALUES(DILFILE,DILFLD,DILFDA,DILOUT) ;
 I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") S DILOUT=0 Q
 K DILOUT
 N DILCNT,DILIEN
 S DILIEN=""
 D VALLOOP
 S DILOUT=DILCNT
 Q
 ;
VALLOOP ;
 S DILCNT=0
 F  S DILIEN=$O(@DILFDA@(DILFILE,DILIEN)) Q:DILIEN=""  D
 . I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) D
 . . S DILCNT=DILCNT+1
 . . S DILOUT(DILCNT)=@DILFDA@(DILFILE,DILIEN,DILFLD)
 . . S DILOUT(DILCNT,"IENS")=DILIEN
 Q
 ;
VALUE1(DILFILE,DILFLD,DILFDA) ;
 I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") Q "^"
 N DILIEN
 S DILIEN=$O(@DILFDA@(DILFILE,""))
 I DILIEN="" Q "^"
 I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) Q @DILFDA@(DILFILE,DILIEN,DILFLD)
 N DILCNT,DILOUT
 D VALLOOP
 I DILCNT Q DILOUT(1)
 Q "^"
 ;
ROUSIZE() ;
 Q $G(^DD("ROU"))
 ;

DILFD
DILFD ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;11/18/94  11:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
ROOT(DIC,DA,CP,ERR) ;
 G ENROOT^DIQGU
 ;
FLDNUM(DIEFF,DIEFFDNM) ;
 G FLDNUMX^DIEF1
 ;
VFILE(F,FLAG) ;
 G VFILEX^DIEFU
 ;
VFIELD(F,FLD,FLAG) ;
 G VFIELDX^DIEFU
 ;
RECALL(DIFILE,DIEN,DIUSER) ;SEA/TOAD
 G RECALLX^DICU
 ;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;SEA/TOAD
 G XTRNLX^DIDU
 ;
PRD(DIFRFILE,DIFRPRD) ;DCL
 G EN^DIFROMSV
 ;

DILIBF
DILIBF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;12/1/94  13:22
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
HTFM(%H,%F) ;$H to FM
 N X,%,%Y,%M,%D S:'$D(%F) %F=0
 S %=%H>21608+%H-.1,%Y=%\365.25+141,%=%#365.25\1
 S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
 S X=%Y_"00"+%M_"00"+%D,%=$P(%H,",",2)
 S %=%#60/100+(%#3600\60)/100+(%\3600)/100
 S:%&('%F) X=X_% Q X
 ;
FMTH(X,%F) ;FM to $H
 N %Y,%H S:'$D(%F) %F=0 D H S:%F %H=+%H Q %H
H ;
 N %,%M,%D,%T I X<1410000 S %H=0,%Y=-1 Q
 S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7)
 S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14)
 S %H=%M>2&'(%Y#4)+$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D
 S %='%M!'%D,%Y=%Y-141,%H=(%H+(%Y*365)+(%Y\4)-(%Y>59)+%)_","_%T,%Y=$S(%:-1,1:%H+4#7)
 Q
 ;
HTE(%H,%F) ;$H to external
 Q:%H'>0 %H N Y,%T,%R S %F=$G(%F) S Y=$$HTFM(%H,0) G T2
FMTE(Y,%F) ;FM to external
 Q:'$G(Y) $G(Y) S %F=$G(%F) Q:($G(DUZ("LANG"))>1) $$OUT^DIALOGU(Y,"FMTE",%F)
 N %T,%R
T2 S %T="."_$E($P(Y,".",2)_"000000",1,7) D @("F"_$S(%F<1:1,%F>7:1,1:+%F\1)) Q %R
DOW(X,Y) ;Day of Week
 N %Y,%M,%D,%H,%T D H I $G(Y) Q %Y
 Q $P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",%Y+1)_"day"
 ;
FMDIFF(X1,X2,X3) ;FM diff in two dates in days if x3=1 seconds if x3=2.
 N %H,%Y,X S:'$D(X3) X3=1 S X=X1 D H S X1=+%H,X1(1)=$P(%H,",",2),X=X2 D H
D2 S X=(X1-%H) S:X3>1 X=X*86400+(X1(1)-$P(%H,",",2))
 I X3=3 S %=X,X="" S:%>86400 X=(%\86400) S:%#86400 X=X_" "_(%#86400\3600)_":"_$E(%#3600\60+100,2,3)_":"_$E(%#60+100,2,3)
 Q X
HDIFF(X1,X2,X3) ;$H diff in two dates, X3 same as FMDIFF.
 N X,%H,%T S:'$D(X3) X3=1 S X1(1)=$P(X1,",",2),X1=+X1,%H=X2
 G D2
HADD(X,D,H,M,S) ;Add to $H date
 N %H,%T S %H=+X,%T=$P(X,",",2) D A2 Q %H_","_%T
A2 S %H=%H+$G(D),%T=%T+($G(H)*3600)+($G(M)*60)+$G(S)
 S:%T>86400 %H=%H+(%T\86400),%T=%T#86400 S:%T<0 %H=%H+(%T\86400)-1,%T=%T#86400
 Q
FMADD(X,D,H,M,S) ;Add to FM date
 N %H,%T S %H=$$FMTH(X,0),%T=$P(%H,",",2) D A2 Q $$HTFM(%H_","_%T)
CONVQQ(X) ; CONVERT SINGLE TO DOUBLE QUOTES IN STRING X
 N Q,F S Q=""""
 F F=0:0 S F=$F(X,Q,F) Q:F=0  S X=$E(X,1,F-2)_Q_Q_$E(X,F,256),F=F+1
 Q X
CONVQ(X) ; CONVERT DOUBLE TO SINGLE QUOTES IN STRING X
 N Q,F,D S Q="""",D=""""""
 F F=0:0 S F=$F(X,D,F) Q:F=0  S X=$E(X,1,F-3)_Q_$E(X,F,256),F=F-1
 Q X
QUOTE(X) ; PUT QUOTES AROUND STRING
 S X=""""_$G(X)_"""" Q X
FNO(X) ; gets a subfile's top level file number
 N Y S X=+X
 I $G(^DIC(X,0))]"" Q X
 F  S Y=+$G(^DD(X,0,"UP")) D  Q:'$D(X)!(Y'>0)
 . I $G(^DIC(Y,0))]"" K X Q
 . S X=Y
 . Q
 Q Y
GLO(Z) ; gets the file number from a global root
 I '$D(@(Z_"0)"))#2 Q 0
 N Y
 S Y=+$P($G(@(Z_"0)")),U,2)
 Q $$FNO(+Y)
UP(X) ; convert string X to uppercase
 I X?.UNP Q X
 N A,B,C S C=""
 F A=1:1:$L(X) S B=$E(X,A) S C=C_$S(B?1L:$C($A(B)-32),1:B)
 Q C
ROUEXIST(X) ; Execute routine existence test
 G:X="" QRER I '$D(DISYS) N DISYS D OS^DII
 I $G(^%ZOSF("TEST"))]"" X ^("TEST") Q $T
 I $G(^DD("OS",DISYS,18))]"" X ^(18) Q $T
QRER Q 0
F5 ;
F1 S %R=$P($S(%F'["U":$T(M),1:$T(MU))," ",$S($E(Y,4,5):$E(Y,4,5)+2,1:0))_$S($E(Y,4,5):" ",1:"")_$S($E(Y,6,7):$S((%F\1'=5):$E(Y,6,7),1:+$E(Y,6,7))_$E(", ",1,1+(%F\1'=5)),1:"")_($E(Y,1,3)+1700)
TM Q:%T'>0!(%F["D")
 I %F'["P" S %R=%R_$S(%F\1'=6:"@",1:" @ ")_$E(%T,2,3)_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:$S(%F\1'=6:"",1:"   "))
 I %F["P" S %R=%R_" "_$S($E(%T,2,3)>12:$E(%T,2,3)-12,1:+$E(%T,2,3))_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:"")_$S($E(%T,2,5)>1200:" pm",1:" am")
 Q
M ;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
MU ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
F2 S %R=+$E(Y,4,5)_"/"_(+$E(Y,6,7))_"/"_$E(Y,2,3)
 G TM
F3 S %R=+$E(Y,6,7)_"/"_(+$E(Y,4,5))_"/"_$E(Y,2,3)
 G TM
F4 S %R=$E(Y,2,3)_"/"_$E(Y,4,5)_"/"_$E(Y,6,7)
 G TM
F6 S %R=$S($E(Y,4,5):$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3))
 G TM
F7 S %R=$S($E(Y,4,5):+$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3))
 G TM
 ;
HKERR(DIFILE,DIIENS,DIFLD,DIHOOK) ;
 N DIEXT
 S DIEXT("FILE")=$G(DIFILE)
 S DIEXT("FIELD")=$G(DIFLD)
 S DIEXT("IENS")=$G(DIIENS)
 S DIEXT(1)=$G(DIHOOK)
 D BLD^DIALOG(120,DIHOOK,.DIEXT)
 Q
 ;

DILL
DILL ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;10/5/92  12:26
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DXS=1
V ;
 S V=$P(X,U,2),DRJ=$F(V,"P") I V["O",$D(^(2)) S Y=Y_" "_^(2),DIO=1,D1="",DLN=30,DRJ=0 D SY G J
 G CLC:V["C",D:'DRJ S V=+$E(V,DRJ,99),D1=$P(X,U,3) I 'V S DRJ=0,@("V=$D(^"_D1_"0))") G D:'V S V=+$P(^(0),U,2)
 D Y S Y=Y_" S Y=$S(Y="""":Y,$D(^"_D1_"Y,0))#2:$P(^(0),U,1),1:Y)" I $D(^DD(V,.01,0)) S X=$P(X,U,1)_U_$P(^(0),U,2,9) G V
D I V["V" D Y S Y=$P(Y," S Y=$S(Y="""":Y,$D(^")_" S C=$P(^DD("_DP_","_+W_",0),U,2) D Y^DIQ:Y S C="","""
 I V["D" S DLN=$P($P(X,"%DT=""",2),"""",1),DLN=$S(DLN["S":21,DLN["T":18,1:11) D W S D1=" D DT" S:DLN>11&DRJ D1=" W ?("_DLN_"-$S(Y#1:18,1:11)+$X)"_D1 S:W[";W" Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_""  ""_$P(Y,""@"",2)" G SY
 I $P(X,"X>",2) S DLN=$L(+$P(X,"X>",2))+3,DRJ=1 G J
 S DLN=+$P(X,"$L(X)>",2) I 'DLN S D1=$P($P(X,U,4),";",2) I D1?1"E"1N.N1","1N.N S DLN=$P(D1,",",2)-D1+1
 I V'["S" S:'DLN DLN=30 G J
 D W S D1=$P(X,U,3) F V=1:1 Q:'$D(DXS(V))
S I D1]"",W[";W"!'$D(DNP) S D2=$P(D1,";",1),D1=$P(D1,";",2,99),D3=$P(D2,":",1),D2=$P(D2,":",2) S:$L(D2)>DLN&'$P(W,";L",2)&'$P(W,";R",2) DLN=$L(D2) S DXS(V,D3)=$E(D2,1,DLN) G S
 D K S D1="$S($D(DXS("_V_",Y)):DXS("_V_",Y),1:Y)" S:DRJ D1="$J("_D1_","_DLN_")" S:W[";W" Y=Y_" S:Y]"""" Y="_D1 S:W'[";W" D1=" W:Y]"""" "_D1
SY D Y S Y=Y_$S($D(DNP):"",1:D1) K D1 Q
 ;
Y I DXS S Y=" S Y="_Y,DXS="Y"
Q Q
 ;
W ;
 F I=";W",";L" I W[I S DRJ=0 S:$P(W,I,2)?1N.E DLN=+$P(W,I,2),I="" G Q
 I $P(X,U,2)["J" S I=$P($P(X,U,2),"J",2),W=W_";R"_$P(I+1,U,I>0) I $P(X,U,2)'["O",I["," S W=W_";D"_+$P(I,",",2)
 I W[";R" S DRJ=1 S:$P(W,";R",2) DLN=+$P(W,";R",2)
 S I=$P($P(W,";D",2),";",1) S:I]"" DRJ=1,I=","_+I Q
 ;
CLC ;
 S Y=" "_$P(X,U,5,99),DXS="X" I V["D" S Y=Y_" S Y=X" G D
 I V?.E1"J"1N.E,W'[";X",W'[";R",V'["," S W=W_";L"_+$P(V,"J",2)
J D W Q:V["m"!$D(DNP)  I '$D(DLN) S Y=Y_" W X" Q
 S D2="" I 'DRJ S V="E(",D3="1,"_DLN
 E  S V="J(",D3=DLN_I I I]"" D Y S D2=":Y]""""" I DXS="X" S D2=":X'?.""*"""
 S Y=$S(DXS:",$"_V_Y,1:Y_" W"_D2_" $"_V_DXS)_","_D3_")" I $P(X,U,2)["C",$L(Y)<225 S Y=Y_" K Y("_DP_","_+W_")"
 I $G(DDXP)=4 S Y=$$DJTOPY^DDXP4(Y)
K K D2,D3 Q

DIM
DIM ;SFISC/JFW,GFT-MUMPS SYNTAX CHECK ;3/19/91  9:45 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %X=X,%ERR=0 G ER:X'?.ANP,ER:" ,"[$E(X,$L(X))
GC G ER:%ERR,END:";"[$E(%X,1),ER:"BCDEFGHIKLNOQRSUWXZ"'[$E(%X)
 D SEP S %COM=$P(%ARG,":"),%=$P(%ARG,":",2,99),%COM(1)=%
 I %ARG[":",%="" G ER
 I $L(%COM)>1 G ER:";BREAK;CLOSE;DO;ELSE;FOR;GOTO;HALT;HANG;IF;KILL;LOCK;NEW;OPEN;QUIT;READ;SET;USE;WRITE;XECUTE;"'[(";"_%COM_";")&(%COM'?1"Z"1.U) S %COM=$E(%COM)
 D ^DIM1:%]"",SEP G ER:("CDGORSUWXZ"[%COM)&(%ARG="")!%ERR,@%COM
B G GC:%ARG=""&(%COM(1)=""),BK^DIM4
C G CL^DIM4
D G DG^DIM3
E G GC:%ARG=""&(%COM(1)="")&(%X]""),ER
F G ER:%COM(1)]"",GC:%ARG=""&(%X]""),FR^DIM3
G G DG^DIM3
H G GC:%ARG=""&(%COM(1)="")&(%X]""),HN^DIM3:%ARG]"",ER Q
I G ER:%COM(1)]"",IX^DIM4
K G GC:%ARG=""&(%COM(1)="")&(%X]""),KL^DIM3:%ARG]"",ER
L G LK^DIM3
N G ER:%ARG=""&(%X=""),K
O G OP^DIM3
Q G ER:%ARG]"",GC:%ARG=""&(%COM(1)=""),BK^DIM4
R G RD^DIM4
S G ST^DIM4
U G OP^DIM3
W G WR^DIM4
X G IX^DIM4
Z G GC
SEP F %I=1:1 S %C=$E(%X,%I) D QUOTE:%C="""" Q:" "[%C
 S %ARG=$E(%X,1,%I-1),%I=%I+1,%X=$E(%X,%I,999) Q
QUOTE S %I=%I+1,%C=$E(%X,%I) I %C="" S %ERR=1 Q
 G QUOTE:%C'="""" S %I=%I+1,%C=$E(%X,%I) G:%C="""" QUOTE Q
ER K X
END K %ERR,%ARG,%C1,%C,%COM,%H,%I,%X,%A,%A1,%A2,%Z,%L,%,%P Q

DIM1
DIM1 ;SFISC/JFW,GFT-MUMPS SYNTAX CHECKER ;7/6/92  8:57 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:%ERR  S (%I,%N,%ERR,%(-1,2),%(-1,3))=0
GG D %INC G:%C="" FINISH^DIM2 I %C="%" F %C=%I+1:1 S %J=$E(%,%C) I %J'?1NU G GG:%J="",E:"""^%"[%J,GG
 G E:%C=";"!($A(%C)>95)!($A(%C)<33),QUOTE:%C="""",FUNC:%C="$",SUB^DIM2:%C="(",UP^DIM2:%C=")",AR^DIM2:%C=",",SEL^DIM2:%C=":",GLO^DIM2:%C="^"
 I %C="E",(($E(%,%I-1)?1N)!($E(%,%I-1)=".")) S %L1=$E(%,%I+1) I %L1?1N!("+-"[%L1) F %I=%I+2:1 S %C=$E(%,%I) I %C'?1N S %I=%I-1 G GG
 I %C?1U D VAR^DIM2
 G E:%ERR,GG:%C="",PAT^DIM2:%C="?",BINOP^DIM2:"=[]<>&!"[%C,MTHOP^DIM2:"/\*#_"[%C
 G UNOP^DIM2:"'+-"[%C,IND^DIM2:%C="@"
 I %C="." G GG:$P($G(%(%N-1,0)),"^")="P" D %INC S %L1=$E(%,%I-2) G E:((%C'?1N)&("':=+-\/<>[],)*&!_#"'[%C))!(("':=+-\/<>[],(_*#!&"'[%L1)&(%L1'?1N))!(%C'?1N&(%L1'?1N))
 I %C?1N,$E(%,%I+1)]"" G E:$E(%,%I+1)'?1NP
GG1 I %C]"","$(),:"""[%C S %I=%I-1
 G GG
QUOTE F %J=0:0 D %INC Q:%C=""!(%C="""")
 G E:%C=""!("[]()><\/+-=&!_#*,;:'"""'[$E(%,%I+1)) D:$D(%(%N-1,"F")) FN:%(%N-1,"F")["FN" G E:%ERR,GG
FUNC D %INC G EXT:%C="$",E:%C'?1U,SPV:$E(%,%I,999)'?.U1"(".E,E:"ACDEFGJLNOPQRSTVZ"'[%C!(%C=""),NFUNC:$E(%,%I,%I+1)="FN"!($E(%,%I,%I+1)="TR"),FUNC1:$E(%,%I+1)="("!(%C="Z")
 S %T=$T(FNC) G E:%T'[(","_$E(%,%I,$F(%,"(",%I)-2)_"^")
FUNC1 S %F1=$P($T(FNC),",",$F("ACDEFGJLNOPQRSTVZ",%C))
FUNC2 S %I=$F(%,"(",%I)-1,%(%N,0)="1^"_$P(%F1,"^",2),%(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%(%N,"F")=%F1,%N=%N+1 S:$E(%F1,1)="S" %(%N-1,2)=1 G DATA^DIM2:"DNOQG"[$E(%F1,1),GG
NFUNC S %T=",FNUMBER^2;3,TRANSLATE^2;3" G NFUNC1:$E(%,%I+2)="(" G E:%T'[(","_$E(%,%I,$F(%,"(",%I)-2)_"^")
NFUNC1 S %F1=$P(%T,",",$F("FT",%C)) G FUNC2
SPV I $E(%,%I+1)?1U S %I=%I+1,%C=%C_$E(%,%I) G SPV
 I "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U)!(",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",")),"[],)><=_&#!'+-*\/?"[$E(%,%I+1) G GG
E G ERR^DIM2
%INC S %I=%I+1,%C=$E(%,%I) Q
FN Q:%(%N-1,1)'=1  F %FZ=%I-1:-1 S %FN=$E(%,%FZ) Q:%FN=""""
 S %FN=$E(%,%FZ+1,%I-1) F %FZ=1:1 Q:$E(%FN,%FZ)=""  I "+-,TP"'[$E(%FN,%FZ) S %ERR=1 Q
 Q:%ERR  I %FN["P" F %FZ=1:1 Q:$E(%FN,%FZ)=""  I "+-T"[$E(%FN,%FZ) S %ERR=1 Q
 Q
EXT D %INC
 F %I=%I+1:1 S %C1=$E(%,%I) Q:%C1?1PC&("^%"'[%C1)!(%C1="")  S %C=%C_%C1
 G:%C="" E G:%C?.E1"^" E
 S %C1=$P(%C,"^",2) I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN G E
 S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G E
 I $E(%,%I)="(",$E(%,%I+1)'=")" S %(%N,0)="P^",(%(%N,1),%(%N,2),%(%N,3))=0,%N=%N+1 G GG
 S %I=%I+$S($E(%,%I,%I+1)="()":1,1:-1)
 G GG:"[],)><=_&#!'+-*/\?"[$E(%,%I+1),E
 ;
FNC ;;,ASCII^1;2,CHAR^1;999,DATA^1;1,EXTRACT^1;3,FIND^2;3,GET^1;1,JUSTIFY^2;3,LENGTH^1;2,NEXT^1;1,ORDER^1;1,PIECE^2;4,QUERY^1;1,RANDOM^1;1,SELECT^1;999,TEXT^1;1,VIEW^1;999,ZFUNC^1;999

DIM2
DIM2 ;SFISC/XAK,GFT-MUMPS SYNTAX CHECKER ;10/31/91  3:26 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SUB F %J=%I-1:-1 S %C1=$E(%,%J) Q:%C1'?1UN
 S %C1=$E(%,%J+1,%I-1) G ERR:%C1]""&(%C1'?1U.UN)&($E(%,%J,%I-1)'?1"%".UN) G:%C1]"" ERR:%[("."_%C1)
 S %(%N,0)=$S(%C1]""!($E(%,%J)="^"):"V^",$E(%,%J)="@":"@^",1:"0^"),%(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%N=%N+1 G 1
UP G ERR:%N=0!("(,"[$E(%,%I-1))!($E(%,%I+1)]""&("<>_[]:/\?'+-=!&#*),"""'[$E(%,%I+1))) S %N=%N-1,%(%N,1)=%(%N,1)+1,%F=$P(%(%N,0),"^",1) G:'%F UP1 S %F=$P(%(%N,0),"^",2)
 S %F1=%(%N,1) G ERR:(%F1<+%F)!(%F1>$P(%F,";",2))!(%(%N,2)&'(%(%N,3)))
UP1 K %(%N+1) G ERR:'%F&(%F'["V")&(%F'["@")&(%F'["P")&(%(%N,1)>1),1
AR G ERR:%N<1!("(,"[$E(%,%I-1))!('%(%N-1,3)&%(%N-1,2))!("@("[$E(%,1,2)) S %(%N-1,1)=%(%N-1,1)+1,%(%N-1,3)=0 G 1
SEL S %(%N-1,3)=%(%N-1,3)+1 G ERR:'%(%N-1,2)!(%(%N-1,3)>1),1
GLO D %INC G ERR:$E(%,%I,999)'?1U.UN.P.E&("%("'[%C)
 G ERR:"=+-\/<>(,#!&*':@[]_"'[$E(%,%I-2)
B S %I=%I-1 G 1
PAT S %L1=1 G ERR:%I=1
C D %INC
C1 I %C?.N G:%C="" ERR:'$D(%L1),FINISH:'%L1,ERR K %L1 G C
 I %C="." K %L1 D %INC G ERR:%C="",P:%C'?1N,C1
 I %C="@" G B
 I %C'?1U,%C'="""" G ERR:'$D(%L1),ERR:%L1,B
P G ERR:$D(%L1) S %L1=0 I %C="""" D QUOTE G C
P1 I "AULPCNE"[%C S %L1=%C D %INC G P1:%C]""
 I %L1?.A G C1
ERR S %ERR=1,%N=0
FINISH G ERR:%N'=0 K %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ Q
BINOP S %Z1=""")%'" G OP
MTHOP S %Z1=""")%" G OP
UNOP S %Z1=""":<>+-'\/()%@#&!*=_][,",%Z2="""($+-=&!^%.@'" S:%C="'" %Z2=%Z2_"<>?[]" G OPCHK
OP S %Z2="""($+-^%@'." G OPCHK
IND G ERR:$E(%COM)="F" S %Z1="^?@(%+-=\/#*!&'_<>[]:,",%Z2="(+^-'$@%"""
OPCHK S %L1=$E(%,%I-1),%L2=$E(%,%I+1) S:"[]&!<>="[%C&(%L1="'") %L1=$E(%,%I-2) I %Z1'[%L1,%L1'?1UN G ERR
 I (%Z2'[%L2)&(%L2'?1UN)!(%L2="") G ERR
 G ERR:%L2=""!(("+-'@"'[%C)&(%L1=""))!(%C="'"&(%L1?1UN)&("[]?=<>"'[%L2))
1 G GG^DIM1
 ;
DATA D %INC G ERR:%C="",DATA:"^@"[%C D %INC:%C="%",VAR G ERR:%ERR!("()"'[%C),GG1^DIM1
QUOTE D %INC I %C="" S %ERR=1 Q
 G QUOTE:%C'="""" Q:$E(%,%I+1)'=%C  S %I=%I+1 G QUOTE
VAR F %J=%I:1 S %C=$E(%,%J) Q:",<>?/\[]+-=_()*&#!':"[%C!((%C="@")&($E(%,%J+1)="(")&($E(%)="@"))  S:%C'?1UN %ERR=1 I (%C="^"),$D(%(%N-1,"F")),%(%N-1,"F")["TEXT" S %ERR=0 Q
 I %C="@"&'%ERR S %I=%J Q
 Q:%ERR  S %F=$E(%,%I,%J-1) S:%F]""&(%F'?1U.UN)&($E(%,%I-1,%J-1)'?1"%".UN)!(%F="^"&($E(%,%J)'="(")) %ERR=1 S %I=%J Q
%INC S %I=%I+1,%C=$E(%,%I)
 Q

DIM3
DIM3 ;SFISC/JFW-MUMPS SYNTAX CHECKER ;7/6/92  2:23 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DG G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR
 S %L=":" D PARS1 G ER:%ERR I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
 I %A["@^" S %=%A D ^DIM1 G DG
 I %A["(",$E(%A)'="@",$E($P(%A,"^",2))'="@" G:%COM'="D" ER S %=%A G PARAM
 S %L="^" D PARS1 G ER:%ERR I %C=%L G ER:%A1="" S %=%A1 D VV,^DIM1 G ER:%ERR
 S %=%A D VV:%A'=+%A,^DIM1 G DG
 ;
PARAM G:%'?.E1"(".E1")" ER
 S %C=$P(%,"("),%C1=$P(%C,"^",2),%I=$F(%,"(")-1
 G:%C="" ER G:%C?.E1"^" ER
 I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN G ER
 S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G ER
 G:$E(%,%I,%I+1)="()" DG
 S (%(-1,2),%(-1,3))=0,%N=1,%(0,0)="P^",(%(0,1),%(0,2),%(0,3))=0
 D GG^DIM1 G DG
 ;
KL D PARS G ER:%ERR!(%A=""&(%C=","))!(%A?1"^"1UP.UN) I %A?1"(".E1")" S %A=$E(%A,2,$L(%A)-1) S:%ARG]"" %ARG=%A_","_%ARG S:%ARG="" %ARG=%A G KL
 S %=$S(%COM="L"&("+-"[$E(%A)):$E(%A,2,999),1:%A) D VV,^DIM1 G GC^DIM:%ARG=""!%ERR,KL
LK S %A=%ARG,%L=":" S:"+-"[$E(%A) %A=$E(%A,2,999) D PARS1 I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
 S %ARG=%A G GC^DIM:%A="",KL
HN S %=%ARG D ^DIM1 G GC^DIM
OP G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR!(%C=","&(%A=""))
 G US:%COM="U" S %L=":" D PARS1 S %A2=%A,%A=%A1 S:%C=%L&(%A="") %ERR=1 D PARS1 G ER:%ERR!(%C=%L&(%A1=""))
 F %L="%A1","%A2" S %=@%L D ^DIM1 G OP:%ERR
 G OP
US S %L=":" D PARS1 G ER:%C=%L&(%A1="") S %=%A D ^DIM1
 S %A=%A1 D PARS1 G ER:%C]"",OP
FR S %L="=",%A=%ARG D PARS1 G ER:%ERR!(%A1="")!(%A="") S %ARG=%A1
 S %=%A G ER:%A?1"^".E D VV,^DIM1 G ER:%ERR
FR1 G GC^DIM:%ARG=""!%ERR D PARS
 S %L=":" F %A=%A,%A1 D PARS1 G ER:%ERR!(%A=""&(%C=%L)) S %=%A D ^DIM1
 I %A1]"" S %=%A1 D ^DIM1
 G FR1
PARS S (%A,%C)="" Q:%ERR  S (%ERR,%I)=0
INC D %INC D QT:%C="""",PARAN:%C="(" Q:%ERR  G OUT:","[%C,INC
QT D %INC Q:%C=""""  G QT:%C]"" S %ERR=1 Q
PARAN S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q
%INC S %I=%I+1,%C=$E(%ARG,%I) Q
 ;
PARS1 S (%A1,%C)="" Q:%ERR  S (%ERR,%I)=0
INCR D %INC1 D QT1:%C="""",PARAN1:%C="(" Q:%ERR=1  G OUT1:%L[%C,INCR
OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
QT1 D %INC1 Q:%C=""""  G QT1:%C]"" S %ERR=1 Q
PARAN1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
%INC1 S %I=%I+1,%C=$E(%A,%I) Q
 ;
VV I '%ERR,%]"",%'["@",%'?1U.UN,%'?1U.UN1"(".E1")",%'?1"%".UN1"(".E1")",%'?1"%".UN,%'?1"^"1U.UN1"(".E1")",%'?1"^%".UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.UN S %ERR=1
 S:%["?@" %ERR=1 Q
ER G ER^DIM

DIM4
DIM4 ;SFISC/JFW-MUMPS SYNTAX CHECKER ;3/20/91  5:21 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BK I %ARG]"" S %=%ARG D ^DIM1 G ER:%ERR
 G GC^DIM
CL G ER:%ERR I %ARG]"" F %Z=0:0 D S S %=%A D ^DIM1 G:%ARG=""!%ERR GC^DIM
IX G GC^DIM:%ARG=""!%ERR D S S %L=":" D S1 I %C=%L S %=%A1 D ^DIM1 G ER:%A1=""!%ERR
 S %=%A D ^DIM1 G IX
ST G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=","))
 I %A?1"@".E S %=%A D ^DIM1 G ST
 S %L="=" D S1 G ER:(%A="")!(%A1="") S %=%A1 D ^DIM1 G ER:%ERR
 I %A?1"(".E1")" S %A=$E(%A,2,$L(%A)-1) G STM
 S %=%A D VV,^DIM1 G ST
STM G ST:%ERR!(%A="") S %L="," D S1 G ER:%ERR!(%C=%L&(%A1=""))
 S %=%A D VV,^DIM1 S %A=%A1 G STM
RD G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%C=","&(%A=""))
 I "!#?"[$E(%A,1) S %I=0 D FRM G RD
 I %A?1"""".E G ER:$P(%A,"""",3)'="" S %=%A D ^DIM1 G RD
 I %A?1"*".E S %A=$E(%A,2,999)
 G ER:%A?1"^".E S %L=":" D S1 G ER:%ERR!(%C=%L&(%A1=""))!(%A="")
 S %=%A D VV,^DIM1 S %=%A1 D ^DIM1 G RD
WR G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=","))
 I "!#?"[$E(%A,1) S %I=0 D FRM G WR
 S:%A?1"*".E %A=$E(%A,2,999) S %=%A D ^DIM1 G WR
FRM S %I=%I+1,%C=$E(%A,%I) Q:%C=""  I "!#?"'[%C S %ERR=1 Q
 G FRM:"!#"[%C S %=$E(%A,%I+1,999) D ^DIM1 Q
S S (%A,%C)="" Q:%ERR  S (%ERR,%I)=0
INC D %INC D QT:%C="""",P:%C="(" Q:%ERR  G OUT:","[%C,INC
QT D %INC Q:%C=""""  G QT:%C]"" S %ERR=1 Q
P S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q
%INC S %I=%I+1,%C=$E(%ARG,%I) Q
 ;
S1 S (%A1,%C)="" Q:%ERR  S (%ERR,%I)=0
INCR D %INC1 D QT1:%C="""",P1:%C="(" Q:%ERR  G OUT1:%L[%C,INCR
OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
QT1 D %INC1 Q:%C=""""  G QT1:%C]"" S %ERR=1 Q
P1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
%INC1 S %I=%I+1,%C=$E(%A,%I) Q
VV I '%ERR,%]"",%'["@",%'?1U.UN,%'?1U.UN1"(".E1")",%'?1"%".UN1"(".E1")",%'?1"%".UN,%'?1"^"1U.UN1"(".E1")",%'?1"^%".UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.UN,%'?1"$"1U,%'?1"$P".E!(%COM'="S") S %ERR=1
 Q
ER G ER^DIM

DINIT
DINIT ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;5/23/96  10:24
V ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D KL^DINIT6
N ;
 D VERSION N DIFROM S DIFROM=VERSION W !!,X D DT^DICRW
 I $G(^DD("VERSION"))]]VERSION W $C(7),!!,"*** WARNING!!  VA FileMan version "_^DD("VERSION")_" is currently loaded on this system.",!,"This Initialization will bring in VA FileMan version "_VERSION_", an earlier version!!",!!
 S Y=$G(^DD("OS")) I Y,"1,2,3,4,5,6,10,11,12,13,15,"[(Y_",") W $C(7),!!,"Your defined operating system entry "_$P($G(^DD("OS",Y,0)),U)_" does not support the",!,"1994 M Standards.",!!,"You may not initialize VA FileMan V21." G KL^DINIT6
DO W !!,"Initialize VA FileMan now?  NO//" R Y:60 G:Y["^"!("Nn"[$E(Y))!('$T) KL^DINIT6
 I "Yy"'[$E(Y) W !,"Answer YES to begin Initializing VA FileMan" G DO
NA W !!,"SITE NAME: " I $D(^DD("SITE")) W ^("SITE"),"// "
 R X:60 G KL^DINIT6:X="^"!'$T I X="",$D(^("SITE"))#2 S X=^("SITE")
 I X'?1AN.ANP W "  ENTER THE NAME OF THIS INSTALLATION SITE",!! G NA
 S %X=X
NO W !!,"SITE NUMBER: " W:$D(^DD("SITE",1)) ^(1),"// "
 R X:60 G KL^DINIT6:X="^"!'$T I $D(^(1)),X="" S X=^(1)
 S:X>0 ^DD("SITE")=%X,^DD("SITE",1)=X
 I X'>0 W "  ENTER A NUMBER, CORRESPONDING TO YOUR INSTITUTION" G NO
 ;***** REMOVE AFTER V21 INIT *****
 D
 . N DIREC F DIREC=0:0 S DIREC=$O(^DI(.84,DIREC)) Q:'DIREC  Q:DIREC>10000  K ^DI(.84,DIREC,5)
 . Q
 ;*********************************
 K ^DD(0) D ^DINIT0,^DINIT11B
 D OSETC
 W ! S Y=1 D OS G KL^DINIT6:Y<0
 W !!,"Now loading other FileMan files--please wait." G GO
 ;
 ;
OS W ! S DIC="^DD(""OS"",",DIC(0)="IAQE",DIC("A")="TYPE OF MUMPS SYSTEM YOU ARE USING: " I $D(^DD("OS"))#2 S (DITZS,DIC("B"))=^("OS") S:DITZS=7 (DITZS,DIC("B"))=18
 E  S (DITZS,^DD("OS"))=100
 D ^DIC K DIC G Q:Y<0 S (DITZS,^DD("OS"))=+Y
 I $D(^%ZTSK),$D(^%ZOSF("OS"))#2,$D(^("MGR"))#2 D
 . S ZTRTN="OS^%RCR",ZTUCI=^%ZOSF("MGR"),ZTDTH=$H,ZTIO="",ZTSAVE("DITZS")=""
 . S ZTDESC="Set Operating System" D ^%ZTLOAD Q
Q K DITZS,ZTSK Q
VERSION ;
 S VERSION=$P($T(V),";",3),X="VA FileMan V."_VERSION Q
 ;
GO S I=$C(126),DIT=$P($H,",",2)
 S $P(^DIBT(0),U,1,2)="TEMPLATE^.4I",$P(^DIE(0),U,1,2)="TEMPLATE^.4I",$P(^DIPT(0),U,1,2)="TEMPLATE^.4I",^(.01,0)="CAPTIONED^",^("F",1)="S DIC=DCC,DA=D0 D EN^DIQ"
 S ^DIPT(.02,0)="FILE SECURITY CODES^^^1",^("F",1)=".01;L20"_I_"0;R13"_I_31_I_33_I_35_I_34_I_32_I_21_I_20
 S ^DIA(0)="AUDIT^1.1I"
 K ^DD(.4),^(.41),^("^"),^(.403),^(.4031),^(.40315),^(.403115),^(.4032),^(.404),^(.40415),^(.4044),^(.404421),^(1.2)
 K ^DIC(.403),^(.404),^(1.2)
 K ^DD(.44),^(.441),^(.4411),^(.447),^(.448),^(.411),^(.42),^(.81),^DIC(.44),^(.81)
 F I=.2,.4,.401,.402,.5,.6,.83,1.1,1.11,1.12,1.13 K ^DIC(I,"%D")
 G ^DINIT0F0
 ;
OSETC ;BRING IN MUMPS OS, DIALOG & LANGUAGE DD AND DATA FOR FILEMAN
 N DN,R,D,DDF,DDT,DTO,DFR,DFN,DTN,DMRG,I,Z,D0
 W !!,"Now loading MUMPS Operating System File"
 D ^DINIT21,OSDD^DINIT24
 S ^DIC(.7,0)="MUMPS OPERATING SYSTEM^.7",^(0,"GL")="^DD(""OS""," D A^DINIT3
 S ^DIC(.7,"%D",0)="^^5^5^2940908^"
 S ^DIC(.7,"%D",1,0)="This file stores operating system-specific code.  Since the code to invoke"
 S ^DIC(.7,"%D",2,0)="some operating system utilities that FileMan uses varies among operating"
 S ^DIC(.7,"%D",3,0)="systems, code to perform these utilities is stored in and executed from"
 S ^DIC(.7,"%D",4,0)="this file.  During the FileMan INIT process an operating system is"
 S ^DIC(.7,"%D",5,0)="selected so that FileMan knows which entry to use from this file."
 K ^DD("OS","B"),DA,DIK S DA(1)=.7 S DIK="^DD(.7," D X^DINIT3
 K DA,DIK S DIK="^DD(""OS""," D X^DINIT3
 D
 . N I,DA,DIK F I=1,2,3,4,5,6,7,10,11,12,13,14,15 S DA=I,DIK="^DD(""OS""," D ^DIK
 . Q
 ;
 K ^UTILITY(U,$J),^UTILITY("DIK",$J) W !!,"Now loading DIALOG and LANGUAGE Files"
 S DN="^DINIT" F R=1:1:45 D @(DN_$$B36(R)) W "."
 S $P(^DIC(.84,0),U,1,2)="DIALOG^.84",$P(^DI(.84,0),U,1,2)="DIALOG^.84I" I $D(^DIC(.84,0,"GL")) D A1^DINIT3
 S $P(^DIC(.85,0),U,1,2)="LANGUAGE^.85",$P(^DI(.85,0),U,1,2)="LANGUAGE^.85I" I $D(^DIC(.85,0,"GL")) D A1^DINIT3
 F I=.84,.841,.842,.844,.845,.847,.8471,.85 D XX^DINIT3
 D DATA
 Q
 ;
DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=0 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
B36(X) Q $$N1(X\(36*36)#36+1)_$$N1(X\36#36+1)_$$N1(X#36+1)
N1(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)

DINIT0
DINIT0 ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;2/24/93  11:39
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT1:X?.P S @("^DD(0,"_$E($P(X," ",2),3,99)_")=Y")
 ;;0 ATTRIBUTE^N
 ;;"SB",.1,1
 ;;.001,0 NUMBER^N^^ ^K:$L(X)>12 X
 ;;.01,0 LABEL^R^^0;1^K:$L(X)>30!(X?1E)!(X["""")!(X["=") X
 ;;.01,1,0 ^.1^1^1
 ;;.01,1,1,0 DA(2)^B
 ;;.01,1,1,1 S @(DIC_"""B"",X,DA)=""""")
 ;;.01,1,1,2 K @(DIC_"""B"",X,DA)")
 ;;.01,"DEL",.2,0 I DUZ(0)'="@",$P(^DD(DA(1),DA,0),"^",2)["X" W !,$C(7),"ONLY A PROGRAMMER CAN DELETE THIS FIELD!"
 ;;.01,"DEL",.3,0 W:$D(^DD("ACOMP",DA(1),DA)) !,$C(7),"WARNING-- A COMPUTED FIELD USES THIS FIELD!" I 0
 ;;.01,"DEL",1,0 I DA=.01 W $C(7),"??"
 ;;.01,"DEL","TRB",0 S %=+$P(^DD(DA(1),DA,0),U,2) I %,$D(^DD(%,"TRB")) S DA(0)=DA,DA=% D TRIG^DIDH S DA=DA(0)
 ;;.01,"DEL","T",0 I $O(^DD(DA(1),DA,5,0))>0 W $C(7),!,"CAN'T DELETE A FIELD THAT HAS A 'TRIGGER' POINTING TO IT!"
 ;;.01,"DEL","ID",0 I $D(^DD(DA(1),0,"ID",DA)) W !,"CAN'T DELETE IDENTIFIER!"
 ;;.1,0 TITLE^F^^.1;E1,999^K:$L(X)>100!(+X=X) X I $D(X),$L(X)<32,@("$D("_DIC_"""B"",X,DA))") K X
 ;;.1,1,0 ^.1^1^1
 ;;.1,1,1,0 DA(2)^B
 ;;.1,1,1,1 S:$L(X)<31 @(DIC_"""B"",X,DA)=1")
 ;;.1,1,1,2 K:$L(X)<31 @(DIC_"""B"",X,DA)")
 ;;.1,3 (OPTIONAL) FULL FIELD NAME  (MUST BE DIFFERENT FROM LABEL)
 ;;.12,0 VARIABLE POINTER^.12^^V;0
 ;;.2,0 SPECIFIER^F^^0;2
 ;;.2,1,0 ^.1^4^4
 ;;.2,1,1,0 DA(2)^SB^ (SUBFILE USED)
 ;;.2,1,1,1 S:X @(DIC_"""SB"",+X,DA)=""""")
 ;;.2,1,1,2 K:X @(DIC_"""SB"",+X,DA)")
 ;;.2,1,2,0 DA(2)^RQ^
 ;;.2,1,2,1 S:X["R" @(DIC_"""RQ"",DA)=""""")
 ;;.2,1,2,2 K:X["R" @(DIC_"""RQ"",DA)")
 ;;.2,1,3,0 ^
 ;;.2,1,3,1 S %=$P(X,"P",2) S:$A(%)=48!%&$D(^DD(+%,0)) ^(0,"PT",DA(1),DA)=""
 ;;.2,1,3,2 S %=$P(X,"P",2) K:$A(%)=48!% ^DD(+%,0,"PT",DA(1),DA)
 ;;.2,9 ^
 ;;.23,0 LENGTH^CJ3^^ ; ^S X=$S($D(@(DCC_"D0,0)")):$P(^(0),U,2),1:""),X=$P(X,"J",2),X=$S(X:+X,1:"")
 ;;.23,9 ^
 ;;.24,0 DECIMAL DEFAULT^CJ1^^ ; ^S @("X=$P("_DCC_"D0,0),U,2)"),X=$P($P(X,"J",2),",",2)
 ;;.25,0 TYPE^CJ15^^ ; ^S X=$P(@(DCC_"D0,0)"),U,2),X=$S(X["C":6,X["N":2,X["P":7,X["S":3,X["D":1,X["V":8,X["K":9,X["W"!$S('X:0,'$D(^DD(+X,.01,0)):0,1:$P(^(0),U,2)["W"):5,1:0),X=$S($D(^DOPT("DICATT",X,0)):$P(^(0)," "),1:"FREE TEXT")
 ;;.25,9 ^

DINIT001
DINIT001 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC(.84,0,"GL")
 ;;=^DI(.84,
 ;;^DIC("B","DIALOG",.84)
 ;;=
 ;;^DIC(.84,"%D",0)
 ;;=^^8^8^2941121^^^^
 ;;^DIC(.84,"%D",1,0)
 ;;=This file stores the dialog used to 'talk' to a user (error messages,
 ;;^DIC(.84,"%D",2,0)
 ;;=help text, and other prompts.) Entry points in the ^DIALOG routine
 ;;^DIC(.84,"%D",3,0)
 ;;=retrieve text from this file.  Variable parameters can be passed to these
 ;;^DIC(.84,"%D",4,0)
 ;;=calls.  The parameters are inserted into windows within the text as it is
 ;;^DIC(.84,"%D",5,0)
 ;;=built.  The text is returned in an array.  This file and associated calls
 ;;^DIC(.84,"%D",6,0)
 ;;=can be used by any package to pass information in arrays rather than
 ;;^DIC(.84,"%D",7,0)
 ;;=writing to the current device.  Record numbers 1 through 10000 are
 ;;^DIC(.84,"%D",8,0)
 ;;=reserved for VA FileMan.
 ;;^DD(.84,0)
 ;;=FIELD^^1.2^10
 ;;^DD(.84,0,"DT")
 ;;=2940526
 ;;^DD(.84,0,"ID","WRITE")
 ;;=N DIALID S DIALID=$O(^(2,0)) S:DIALID DIALID(1)=$E($G(^(DIALID,0)),1,42),DIALID(1,"F")="?10" D EN^DDIOL(.DIALID)
 ;;^DD(.84,0,"IX","B",.84,.01)
 ;;=
 ;;^DD(.84,0,"IX","C",.84,1.2)
 ;;=
 ;;^DD(.84,0,"NM","DIALOG")
 ;;=
 ;;^DD(.84,.01,0)
 ;;=DIALOG NUMBER^RNJ13,3X^^0;1^K:+X'=X!(X>999999999.999)!(('$G(DIFROM))&(X<10000.001))!(X?.E1"."4N.N) X S:$G(X) DINUM=X
 ;;^DD(.84,.01,1,0)
 ;;=^.1
 ;;^DD(.84,.01,1,1,0)
 ;;=.84^B
 ;;^DD(.84,.01,1,1,1)
 ;;=S ^DI(.84,"B",$E(X,1,30),DA)=""
 ;;^DD(.84,.01,1,1,2)
 ;;=K ^DI(.84,"B",$E(X,1,30),DA)
 ;;^DD(.84,.01,3)
 ;;=Type a Number between 10000.001 and 999999999.999, up to 3 Decimal Digits
 ;;^DD(.84,.01,21,0)
 ;;=^^1^1^2940523^
 ;;^DD(.84,.01,21,1,0)
 ;;=The dialogue number is used to uniquely identify a message.
 ;;^DD(.84,.01,"DT")
 ;;=2940623
 ;;^DD(.84,1,0)
 ;;=TYPE^RS^1:ERROR;2:GENERAL MESSAGE;3:HELP;^0;2^Q
 ;;^DD(.84,1,3)
 ;;=Enter code that reflects how this dialogue is used when talking to the users.
 ;;^DD(.84,1,21,0)
 ;;=^^2^2^2940523^
 ;;^DD(.84,1,21,1,0)
 ;;=This code is used to group the entries in the FileMan DIALOG file,
 ;;^DD(.84,1,21,2,0)
 ;;=according to how they are used when interacting with the user.
 ;;^DD(.84,1,23,0)
 ;;=^^3^3^2940523^
 ;;^DD(.84,1,23,1,0)
 ;;=This field is used to tell the DIALOG routines what array to use in
 ;;^DD(.84,1,23,2,0)
 ;;=returning the dialogue.  It is also used for grouping the dialogue for
 ;;^DD(.84,1,23,3,0)
 ;;=reporting purposes.
 ;;^DD(.84,1,"DT")
 ;;=2940523
 ;;^DD(.84,1.2,0)
 ;;=PACKAGE^RP9.4'^DIC(9.4,^0;4^Q
 ;;^DD(.84,1.2,1,0)
 ;;=^.1
 ;;^DD(.84,1.2,1,1,0)
 ;;=.84^C
 ;;^DD(.84,1.2,1,1,1)
 ;;=S ^DI(.84,"C",$E(X,1,30),DA)=""
 ;;^DD(.84,1.2,1,1,2)
 ;;=K ^DI(.84,"C",$E(X,1,30),DA)
 ;;^DD(.84,1.2,1,1,"%D",0)
 ;;=^^3^3^2940623^
 ;;^DD(.84,1.2,1,1,"%D",1,0)
 ;;=Cross-reference on Package file.  Used for identifying DIALOG entries by
 ;;^DD(.84,1.2,1,1,"%D",2,0)
 ;;=the package that owns the entry, and for populating the BUILD file during
 ;;^DD(.84,1.2,1,1,"%D",3,0)
 ;;=package distribution.
 ;;^DD(.84,1.2,1,1,"DT")
 ;;=2940623
 ;;^DD(.84,1.2,3)
 ;;=Enter the name of the Package that owns and distributes this entry.
 ;;^DD(.84,1.2,21,0)
 ;;=^^3^3^2940526^
 ;;^DD(.84,1.2,21,1,0)
 ;;=This is a pointer to the Package file.  Each entry in this file belongs
 ;;^DD(.84,1.2,21,2,0)
 ;;=to, and is distributed by, a certain package.  The Package field should be
 ;;^DD(.84,1.2,21,3,0)
 ;;=filled in for each entry on this file.
 ;;^DD(.84,1.2,"DT")
 ;;=2940623
 ;;^DD(.84,2,0)
 ;;=DESCRIPTION^.842^^1;0
 ;;^DD(.84,2,21,0)
 ;;=^^1^1^2930824^^
 ;;^DD(.84,2,21,1,0)
 ;;=  Used for internal documentation purposes.
 ;;^DD(.84,3,0)
 ;;=INTERNAL PARAMETERS NEEDED^S^y:YES;^0;3^Q
 ;;^DD(.84,3,3)
 ;;=
 ;;^DD(.84,3,21,0)
 ;;=^^6^6^2931105^
 ;;^DD(.84,3,21,1,0)
 ;;=  Some dialogue is built by inserting variable text (internal parameters)
 ;;^DD(.84,3,21,2,0)
 ;;=into windows in the word-processing TEXT field.  The insertable text might
 ;;^DD(.84,3,21,3,0)
 ;;=be, for example, File or Field names.  This field should be set to YES if
 ;;^DD(.84,3,21,4,0)
 ;;=any internal parameters need to be inserted into the TEXT.  If the field
 ;;^DD(.84,3,21,5,0)
 ;;=is not set to YES, the DIALOG routine will not go through the part of the
 ;;^DD(.84,3,21,6,0)
 ;;=code that stuffs the internal parameters into the text.
 ;;^DD(.84,3,"DT")
 ;;=2931105
 ;;^DD(.84,4,0)
 ;;=TEXT^.844^^2;0
 ;;^DD(.84,4,21,0)
 ;;=^^7^7^2941122^

DINIT002
DINIT002 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.84,4,21,1,0)
 ;;=Actual text of the message.  If parameters (variable pieces of text) are
 ;;^DD(.84,4,21,2,0)
 ;;=to be inserted into the dialogue when the message is built, the parameter
 ;;^DD(.84,4,21,3,0)
 ;;=will appear as a 'window' in this TEXT field, surrounded by vertical bars.
 ;;^DD(.84,4,21,4,0)
 ;;=The data within the 'window' will represent a subscript of the input
 ;;^DD(.84,4,21,5,0)
 ;;=parameter list that is passed to BLD^DIALOG or $$EZBLD^DIALOG when
 ;;^DD(.84,4,21,6,0)
 ;;=building the message. This same subscript should be used as the .01 of the
 ;;^DD(.84,4,21,7,0)
 ;;=PARAMETER field in this file to document the parameter.
 ;;^DD(.84,5,0)
 ;;=PARAMETER^.845^^3;0
 ;;^DD(.84,6,0)
 ;;=POST MESSAGE ACTION^K^^6;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.84,6,3)
 ;;=This is Standard MUMPS code.  This code will be executed whenever this message is retrieved through a call to BLD^DIALOG or $$EZBLD^DIALOG.
 ;;^DD(.84,6,9)
 ;;=@
 ;;^DD(.84,6,21,0)
 ;;=^^6^6^2941122^
 ;;^DD(.84,6,21,1,0)
 ;;=If some special action should be taken whenever this message is built,
 ;;^DD(.84,6,21,2,0)
 ;;=MUMPS code can be entered here.  This code will be executed by the
 ;;^DD(.84,6,21,3,0)
 ;;=BLD^DIALOG or $$EZBLD^DIALOG routines, immediately after the message text
 ;;^DD(.84,6,21,4,0)
 ;;=has been built in the output array.  For example, the code could set a
 ;;^DD(.84,6,21,5,0)
 ;;=special flag into a global or local variable to notify the calling routine
 ;;^DD(.84,6,21,6,0)
 ;;=that some extra action needed to be taken.
 ;;^DD(.84,6,23,0)
 ;;=^^7^7^2941122^
 ;;^DD(.84,6,23,1,0)
 ;;=At the time of executing this code
 ;;^DD(.84,6,23,2,0)
 ;;= D0 = IEN for the entry in the DIALOG file
 ;;^DD(.84,6,23,3,0)
 ;;= DIPI(n) = (for sequential number n) parameters incorporated in the text.
 ;;^DD(.84,6,23,4,0)
 ;;= DIPE(n) = parameters output back to the user
 ;;^DD(.84,6,23,5,0)
 ;;= 
 ;;^DD(.84,6,23,6,0)
 ;;=All other variables used in this code should use your packages namespace,
 ;;^DD(.84,6,23,7,0)
 ;;=and should be NEWed.
 ;;^DD(.84,6,"DT")
 ;;=2940520
 ;;^DD(.84,7,0)
 ;;=TRANSLATION^.847P^^4;0
 ;;^DD(.84,8,0)
 ;;=CALLED FROM ENTRY POINTS^.841^^5;0
 ;;^DD(.841,0)
 ;;=CALLED FROM ENTRY POINTS SUB-FIELD^^.05^2
 ;;^DD(.841,0,"DT")
 ;;=2940411
 ;;^DD(.841,0,"IX","B",.841,.01)
 ;;=
 ;;^DD(.841,0,"NM","CALLED FROM ENTRY POINTS")
 ;;=
 ;;^DD(.841,0,"UP")
 ;;=.84
 ;;^DD(.841,.01,0)
 ;;=ROUTINE NAME^MF^^0;1^K:$L(X)>8!($L(X)<1) X
 ;;^DD(.841,.01,1,0)
 ;;=^.1
 ;;^DD(.841,.01,1,1,0)
 ;;=.841^B
 ;;^DD(.841,.01,1,1,1)
 ;;=S ^DI(.84,DA(1),5,"B",$E(X,1,30),DA)=""
 ;;^DD(.841,.01,1,1,2)
 ;;=K ^DI(.84,DA(1),5,"B",$E(X,1,30),DA)
 ;;^DD(.841,.01,3)
 ;;=Answer must be 1-8 characters in length.
 ;;^DD(.841,.01,21,0)
 ;;=^^6^6^2940411^
 ;;^DD(.841,.01,21,1,0)
 ;;=This multiple is used for documentation only.  Entries are made to this
 ;;^DD(.841,.01,21,2,0)
 ;;=subfile ONLY for ERROR type text.  Enter the routine name of an entry
 ;;^DD(.841,.01,21,3,0)
 ;;=point that may generate this error message.  You only need to enter the
 ;;^DD(.841,.01,21,4,0)
 ;;=names of routines that directly generate the error through a call to
 ;;^DD(.841,.01,21,5,0)
 ;;=^DIALOG, and not when the error is generated by some other utility called
 ;;^DD(.841,.01,21,6,0)
 ;;=from your routine.
 ;;^DD(.841,.01,"DT")
 ;;=2940411
 ;;^DD(.841,.05,0)
 ;;=LINE TAG^F^^0;2^K:$L(X)>10!($L(X)<1) X
 ;;^DD(.841,.05,3)
 ;;=Answer must be 1-10 characters in length.
 ;;^DD(.841,.05,21,0)
 ;;=^^6^6^2940411^
 ;;^DD(.841,.05,21,1,0)
 ;;=This multiple is used for documentation only.  Entries are made to this
 ;;^DD(.841,.05,21,2,0)
 ;;=subfile ONLY for ERROR type text.  Enter the line tag of an entry point
 ;;^DD(.841,.05,21,3,0)
 ;;=that may generate this error message.  You only need to enter the names of
 ;;^DD(.841,.05,21,4,0)
 ;;=routines that directly generate the error through a call to ^DIALOG, and
 ;;^DD(.841,.05,21,5,0)
 ;;=not when the error is generated by some other utility called from your
 ;;^DD(.841,.05,21,6,0)
 ;;=routine.
 ;;^DD(.841,.05,"DT")
 ;;=2940411
 ;;^DD(.842,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(.842,0,"DT")
 ;;=2930614
 ;;^DD(.842,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(.842,0,"UP")
 ;;=.84
 ;;^DD(.842,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(.842,.01,3)
 ;;=Describe the use of this dialogue.
 ;;^DD(.842,.01,"DT")
 ;;=2930614

DINIT003
DINIT003 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.844,0)
 ;;=TEXT SUB-FIELD^^.01^1
 ;;^DD(.844,0,"DT")
 ;;=2930811
 ;;^DD(.844,0,"NM","TEXT")
 ;;=
 ;;^DD(.844,0,"UP")
 ;;=.84
 ;;^DD(.844,.01,0)
 ;;=TEXT^WL^^0;1^Q
 ;;^DD(.844,.01,3)
 ;;=Enter the actual text of the dialogue, with optional parameter windows.
 ;;^DD(.844,.01,"DT")
 ;;=2930811
 ;;^DD(.845,0)
 ;;=PARAMETER SUB-FIELD^^1^2
 ;;^DD(.845,0,"DT")
 ;;=2931105
 ;;^DD(.845,0,"IX","B",.845,.01)
 ;;=
 ;;^DD(.845,0,"NM","PARAMETER")
 ;;=
 ;;^DD(.845,0,"UP")
 ;;=.84
 ;;^DD(.845,.01,0)
 ;;=PARAMETER SUBSCRIPT^MF^^0;1^K:$L(X)>20!($L(X)<1) X
 ;;^DD(.845,.01,1,0)
 ;;=^.1
 ;;^DD(.845,.01,1,1,0)
 ;;=.845^B
 ;;^DD(.845,.01,1,1,1)
 ;;=S ^DI(.84,DA(1),3,"B",$E(X,1,30),DA)=""
 ;;^DD(.845,.01,1,1,2)
 ;;=K ^DI(.84,DA(1),3,"B",$E(X,1,30),DA)
 ;;^DD(.845,.01,3)
 ;;=This entry corresponds to the subscript of an entry in either the text or output parameter list to the BLD^DIALOG and $$EZBLD^DIALOG routine.  Answer must be 1-20 characters in length.
 ;;^DD(.845,.01,21,0)
 ;;=^^7^7^2941122^
 ;;^DD(.845,.01,21,1,0)
 ;;=This multiple is used for documentation purposes only.  The entry in the
 ;;^DD(.845,.01,21,2,0)
 ;;=.01 field of this multiple will correspond to a subscript in either the
 ;;^DD(.845,.01,21,3,0)
 ;;=text or output parameter list, that are passed to the routines that build
 ;;^DD(.845,.01,21,4,0)
 ;;=dialogue messages, BLD^DIALOG and $$EZBLD^DIALOG. This routine will insert
 ;;^DD(.845,.01,21,5,0)
 ;;=into each 'window' from the TEXT field, the corresponding entry out of the
 ;;^DD(.845,.01,21,6,0)
 ;;=text parameter list.  For errors only, it passes any entries from the
 ;;^DD(.845,.01,21,7,0)
 ;;=output parameter list back to the user as entries in its output array.
 ;;^DD(.845,.01,"DT")
 ;;=2931105
 ;;^DD(.845,1,0)
 ;;=PARAMETER DESCRIPTION^F^^0;2^K:$L(X)>230!($L(X)<1) X
 ;;^DD(.845,1,3)
 ;;=Describe the Parameter for documentation purposes.  Answer must be 1-230 characters in length.
 ;;^DD(.845,1,21,0)
 ;;=^^5^5^2941122^
 ;;^DD(.845,1,21,1,0)
 ;;=This field is used for documentation purposes only.  It describes the text
 ;;^DD(.845,1,21,2,0)
 ;;=and/or output parameter(s) that are passed to BLD^DIALOG and
 ;;^DD(.845,1,21,3,0)
 ;;=$$EZBLD^DIALOG. The same parameter can be used both as a text parameter
 ;;^DD(.845,1,21,4,0)
 ;;=(i.e., inserted into the text when it is built), and as an output
 ;;^DD(.845,1,21,5,0)
 ;;=parameter (i.e., a parameter passed back in a list to the user)
 ;;^DD(.845,1,"DT")
 ;;=2930614
 ;;^DD(.847,0)
 ;;=TRANSLATION SUB-FIELD^^1^2
 ;;^DD(.847,0,"DT")
 ;;=2940524
 ;;^DD(.847,0,"IX","B",.847,.01)
 ;;=
 ;;^DD(.847,0,"NM","TRANSLATION")
 ;;=
 ;;^DD(.847,0,"UP")
 ;;=.84
 ;;^DD(.847,.01,0)
 ;;=LANGUAGE^M*P.85'X^DI(.85,^0;1^S DIC("S")="I Y>1" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X S:$G(X) DINUM=X
 ;;^DD(.847,.01,1,0)
 ;;=^.1
 ;;^DD(.847,.01,1,1,0)
 ;;=.847^B
 ;;^DD(.847,.01,1,1,1)
 ;;=S ^DI(.84,DA(1),4,"B",$E(X,1,30),DA)=""
 ;;^DD(.847,.01,1,1,2)
 ;;=K ^DI(.84,DA(1),4,"B",$E(X,1,30),DA)
 ;;^DD(.847,.01,3)
 ;;=Enter the number or name for a non-English language.
 ;;^DD(.847,.01,12)
 ;;=English language cannot be selected.
 ;;^DD(.847,.01,12.1)
 ;;=S DIC("S")="I Y>1"
 ;;^DD(.847,.01,21,0)
 ;;=^^3^3^2941118^^
 ;;^DD(.847,.01,21,1,0)
 ;;=Pointer to the LANGUAGE file. If FileMan system variable DUZ("LANG") is
 ;;^DD(.847,.01,21,2,0)
 ;;=set to an integer greater than 1, we use that number to extract dialogue
 ;;^DD(.847,.01,21,3,0)
 ;;=text for the specified language from this multiple.
 ;;^DD(.847,.01,"DT")
 ;;=2940524
 ;;^DD(.847,1,0)
 ;;=FOREIGN TEXT^.8471^^1;0
 ;;^DD(.847,1,21,0)
 ;;=^^3^3^2941118^
 ;;^DD(.847,1,21,1,0)
 ;;=Insert here the non-English equivalent for this language to the text in
 ;;^DD(.847,1,21,2,0)
 ;;=the TEXT field for this entry.  This field may contain windows for
 ;;^DD(.847,1,21,3,0)
 ;;=variable parameters the same as the TEXT field.
 ;;^DD(.8471,0)
 ;;=FOREIGN TEXT SUB-FIELD^^.01^1
 ;;^DD(.8471,0,"DT")
 ;;=2930811
 ;;^DD(.8471,0,"NM","FOREIGN TEXT")
 ;;=
 ;;^DD(.8471,0,"UP")
 ;;=.847
 ;;^DD(.8471,.01,0)
 ;;=FOREIGN TEXT^WL^^0;1^Q
 ;;^DD(.8471,.01,3)
 ;;=Enter the non-English dialog text
 ;;^DD(.8471,.01,"DT")
 ;;=2930811

DINIT004
DINIT004 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84)
 ;;=^DI(.84,
 ;;^UTILITY(U,$J,.84,0)
 ;;=DIALOG^.84I^630^271
 ;;^UTILITY(U,$J,.84,101,0)
 ;;=101^1^^11
 ;;^UTILITY(U,$J,.84,101,1,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,101,1,1,0)
 ;;=The option or function can only be done if DUZ(0)="@", designating 
 ;;^UTILITY(U,$J,.84,101,1,2,0)
 ;;=the user as having programmer access.
 ;;^UTILITY(U,$J,.84,101,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,101,2,1,0)
 ;;=Only those with programmer's access can perform this function.
 ;;^UTILITY(U,$J,.84,110,0)
 ;;=110^1^^11
 ;;^UTILITY(U,$J,.84,110,1,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,110,1,1,0)
 ;;=An attempt to get a lock timed out.  The record is locked and the desired
 ;;^UTILITY(U,$J,.84,110,1,2,0)
 ;;=action cannot be taken until the lock is released.
 ;;^UTILITY(U,$J,.84,110,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,110,2,1,0)
 ;;=The record is currently locked.
 ;;^UTILITY(U,$J,.84,110,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,110,3,1,0)
 ;;=FILE^File or subfile #.
 ;;^UTILITY(U,$J,.84,110,3,2,0)
 ;;=IENS^IEN string of entry numbers.
 ;;^UTILITY(U,$J,.84,110,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,110,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,111,0)
 ;;=111^1^y^11^
 ;;^UTILITY(U,$J,.84,111,1,0)
 ;;=^^2^2^2940215^
 ;;^UTILITY(U,$J,.84,111,1,1,0)
 ;;=An attempt to get a lock timed out. The File Header Node is locked, and
 ;;^UTILITY(U,$J,.84,111,1,2,0)
 ;;=the desired action cannot be taken until the lock is released.
 ;;^UTILITY(U,$J,.84,111,2,0)
 ;;=^^1^1^2940215^
 ;;^UTILITY(U,$J,.84,111,2,1,0)
 ;;=The File Header Node is currently locked.
 ;;^UTILITY(U,$J,.84,111,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,111,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,111,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,111,5,1,0)
 ;;=0
 ;;^UTILITY(U,$J,.84,120,0)
 ;;=120^1^y^11
 ;;^UTILITY(U,$J,.84,120,1,0)
 ;;=^^7^7^2941006^^
 ;;^UTILITY(U,$J,.84,120,1,1,0)
 ;;=An error occurred during the Xecution of a FileMan hook (e.g., an input
 ;;^UTILITY(U,$J,.84,120,1,2,0)
 ;;=transform, DIC screen).  The type of hook in which the error occurred is
 ;;^UTILITY(U,$J,.84,120,1,3,0)
 ;;=identified in the text.  When relevant, the file, field, and IENS for
 ;;^UTILITY(U,$J,.84,120,1,4,0)
 ;;=which the hook was being Xecuted are identified in the PARAM nodes.  The
 ;;^UTILITY(U,$J,.84,120,1,5,0)
 ;;=substance of the error will usually be identified by a separate error
 ;;^UTILITY(U,$J,.84,120,1,6,0)
 ;;=message generated during the Xecution of the hook itself. That error will
 ;;^UTILITY(U,$J,.84,120,1,7,0)
 ;;=usually be the one preceding this one in the DIERR array.
 ;;^UTILITY(U,$J,.84,120,2,0)
 ;;=^^1^1^2941006^^
 ;;^UTILITY(U,$J,.84,120,2,1,0)
 ;;=The previous error occurred when performing an action specified in a |1|.
 ;;^UTILITY(U,$J,.84,120,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,120,3,1,0)
 ;;=1^Type of FileMan Xecutable code.
 ;;^UTILITY(U,$J,.84,120,3,2,0)
 ;;=FILE^File#
 ;;^UTILITY(U,$J,.84,120,3,3,0)
 ;;=FIELD^Field#.
 ;;^UTILITY(U,$J,.84,120,3,4,0)
 ;;=IENS^Internal Entry Number String.
 ;;^UTILITY(U,$J,.84,200,0)
 ;;=200^1^^11
 ;;^UTILITY(U,$J,.84,200,1,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,200,1,1,0)
 ;;=There is an error in one of the variables passed to a FileMan call or
 ;;^UTILITY(U,$J,.84,200,1,2,0)
 ;;=in one of the parameters passed in the actual parameter list.
 ;;^UTILITY(U,$J,.84,200,2,0)
 ;;=^^1^1^2931110^^^
 ;;^UTILITY(U,$J,.84,200,2,1,0)
 ;;=An input variable or parameter is missing or invalid.
 ;;^UTILITY(U,$J,.84,201,0)
 ;;=201^1^y^11^
 ;;^UTILITY(U,$J,.84,201,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,201,1,1,0)
 ;;=The specified input variable is either 1) required but not defined or
 ;;^UTILITY(U,$J,.84,201,1,2,0)
 ;;=2) not valid.
 ;;^UTILITY(U,$J,.84,201,2,0)
 ;;=^^1^1^2931110^^^
 ;;^UTILITY(U,$J,.84,201,2,1,0)
 ;;=The input variable |1| is missing or invalid.
 ;;^UTILITY(U,$J,.84,201,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,201,3,1,0)
 ;;=1^Variable name.
 ;;^UTILITY(U,$J,.84,202,0)
 ;;=202^1^y^11^
 ;;^UTILITY(U,$J,.84,202,1,0)
 ;;=^^1^1^2931110^^^^
 ;;^UTILITY(U,$J,.84,202,1,1,0)
 ;;=The specified parameter is either required but missing or invalid.
 ;;^UTILITY(U,$J,.84,202,2,0)
 ;;=^^1^1^2931110^^^
 ;;^UTILITY(U,$J,.84,202,2,1,0)
 ;;=The input parameter that identifies the |1| is missing or invalid.
 ;;^UTILITY(U,$J,.84,202,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,202,3,1,0)
 ;;=1^Parameter as identified in the FM documentation.

DINIT005
DINIT005 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,202,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,202,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,203,0)
 ;;=203^1^y^11^
 ;;^UTILITY(U,$J,.84,203,1,0)
 ;;=^^3^3^2940426^
 ;;^UTILITY(U,$J,.84,203,1,1,0)
 ;;=An incorrect subscript is present in an array that is passed to FileMan.
 ;;^UTILITY(U,$J,.84,203,1,2,0)
 ;;=For example, one of the subscripts in the FDA which identifies FILE, IENS,
 ;;^UTILITY(U,$J,.84,203,1,3,0)
 ;;=or FIELD is incorrectly formatted.
 ;;^UTILITY(U,$J,.84,203,2,0)
 ;;=^^1^1^2940426^^^
 ;;^UTILITY(U,$J,.84,203,2,1,0)
 ;;=The subscript that identifies the |1| is missing or invalid.
 ;;^UTILITY(U,$J,.84,203,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,203,3,1,0)
 ;;=1^The data element incorrectly specified by a subscript.
 ;;^UTILITY(U,$J,.84,203,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,203,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,204,0)
 ;;=204^1^^11
 ;;^UTILITY(U,$J,.84,204,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,204,1,1,0)
 ;;=Control characters are not permitted in the database.
 ;;^UTILITY(U,$J,.84,204,2,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,204,2,1,0)
 ;;=The input value contains control characters.
 ;;^UTILITY(U,$J,.84,204,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,204,3,1,0)
 ;;=1^INPUT VALUE
 ;;^UTILITY(U,$J,.84,205,0)
 ;;=205^1^y^11^
 ;;^UTILITY(U,$J,.84,205,1,0)
 ;;=^^4^4^2941017^^^^
 ;;^UTILITY(U,$J,.84,205,1,1,0)
 ;;=Error message output when a file or subfile number, and its associated IEN
 ;;^UTILITY(U,$J,.84,205,1,2,0)
 ;;=string are not in sync.  (I.E., the number of comma pieces represented by
 ;;^UTILITY(U,$J,.84,205,1,3,0)
 ;;=the IEN string do not match the file/subfile level according to the "UP"
 ;;^UTILITY(U,$J,.84,205,1,4,0)
 ;;=nodes.
 ;;^UTILITY(U,$J,.84,205,2,0)
 ;;=^^1^1^2941018^^
 ;;^UTILITY(U,$J,.84,205,2,1,0)
 ;;=File# |1| and IEN string |IENS| represent different subfile levels.
 ;;^UTILITY(U,$J,.84,205,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,205,3,1,0)
 ;;=1^File or subfile number
 ;;^UTILITY(U,$J,.84,205,3,2,0)
 ;;=IENS^IEN string
 ;;^UTILITY(U,$J,.84,205,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,205,5,1,0)
 ;;=DIT3^IENCHK
 ;;^UTILITY(U,$J,.84,205,5,2,0)
 ;;=DICA3^ERR
 ;;^UTILITY(U,$J,.84,299,0)
 ;;=299^1^y^11^
 ;;^UTILITY(U,$J,.84,299,1,0)
 ;;=^^2^2^2940401^^
 ;;^UTILITY(U,$J,.84,299,1,1,0)
 ;;=A lookup that was restricted to finding a single entry found more than
 ;;^UTILITY(U,$J,.84,299,1,2,0)
 ;;=one.
 ;;^UTILITY(U,$J,.84,299,2,0)
 ;;=^^1^1^2940401^^^
 ;;^UTILITY(U,$J,.84,299,2,1,0)
 ;;=More than one entry matches the value '|1|'.
 ;;^UTILITY(U,$J,.84,299,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,299,3,1,0)
 ;;=1^Lookup Value.
 ;;^UTILITY(U,$J,.84,299,3,2,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,299,3,3,0)
 ;;=IENS^IEN String.
 ;;^UTILITY(U,$J,.84,301,0)
 ;;=301^1^y^11^
 ;;^UTILITY(U,$J,.84,301,1,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,301,1,1,0)
 ;;=Flags passed in a variable (like DIC(0)) or in a parameter are incorrect.
 ;;^UTILITY(U,$J,.84,301,2,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,301,2,1,0)
 ;;=The passed flag(s) '|1|' are unknown or inconsistent.
 ;;^UTILITY(U,$J,.84,301,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,301,3,1,0)
 ;;=1^Letter(s) from flag.
 ;;^UTILITY(U,$J,.84,302,0)
 ;;=302^1^y^11^
 ;;^UTILITY(U,$J,.84,302,1,0)
 ;;=^^2^2^2940215^
 ;;^UTILITY(U,$J,.84,302,1,1,0)
 ;;=The calling application has asked us to add a new record, and has supplied
 ;;^UTILITY(U,$J,.84,302,1,2,0)
 ;;=a record number, but a record already exists at that number.
 ;;^UTILITY(U,$J,.84,302,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,302,2,1,0)
 ;;=Entry '|IENS|' already exists.
 ;;^UTILITY(U,$J,.84,302,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,302,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,302,3,2,0)
 ;;=IENS^IEN String.
 ;;^UTILITY(U,$J,.84,304,0)
 ;;=304^1^y^11
 ;;^UTILITY(U,$J,.84,304,1,0)
 ;;=^^2^2^2940628^^^^
 ;;^UTILITY(U,$J,.84,304,1,1,0)
 ;;=The problem with this IEN string is that it lacks the final ','. This is a
 ;;^UTILITY(U,$J,.84,304,1,2,0)
 ;;=common mistake for beginners.
 ;;^UTILITY(U,$J,.84,304,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,304,2,1,0)
 ;;=The IENS '|IENS|' lacks a final comma.
 ;;^UTILITY(U,$J,.84,304,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,304,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,305,0)
 ;;=305^1^y^11^
 ;;^UTILITY(U,$J,.84,305,1,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,305,1,1,0)
 ;;=A root is used to identify an input array.  But the array is empty.

DINIT006
DINIT006 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,305,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,305,2,1,0)
 ;;=The array with a root of '|1|' has no data associated with it.
 ;;^UTILITY(U,$J,.84,305,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,305,3,1,0)
 ;;=1^Passed root.
 ;;^UTILITY(U,$J,.84,305,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,305,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,306,0)
 ;;=306^1^y^11
 ;;^UTILITY(U,$J,.84,306,1,0)
 ;;=^^2^2^2940628^
 ;;^UTILITY(U,$J,.84,306,1,1,0)
 ;;=When an IENS is used to explicitly identify a subfile, not a subfile
 ;;^UTILITY(U,$J,.84,306,1,2,0)
 ;;=entry, then the first comma-piece should be empty. This one wasn't.
 ;;^UTILITY(U,$J,.84,306,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,306,2,1,0)
 ;;=The first comma-piece of IENS '|IENS|' should be empty.
 ;;^UTILITY(U,$J,.84,306,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,306,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,307,0)
 ;;=307^1^y^11
 ;;^UTILITY(U,$J,.84,307,1,0)
 ;;=^^2^2^2940629^
 ;;^UTILITY(U,$J,.84,307,1,1,0)
 ;;=One of the IENs in the IENS has been left out, leaving an empty
 ;;^UTILITY(U,$J,.84,307,1,2,0)
 ;;=comma-piece. 
 ;;^UTILITY(U,$J,.84,307,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,307,2,1,0)
 ;;=The IENS '|IENS|' has an empty comma-piece.
 ;;^UTILITY(U,$J,.84,307,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,307,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,308,0)
 ;;=308^1^y^11
 ;;^UTILITY(U,$J,.84,308,1,0)
 ;;=^^3^3^2940629^
 ;;^UTILITY(U,$J,.84,308,1,1,0)
 ;;=The syntax of this IENS is incorrect. For example, a record number may be
 ;;^UTILITY(U,$J,.84,308,1,2,0)
 ;;=illegal; or a subfile may be specified as already existing, but have a
 ;;^UTILITY(U,$J,.84,308,1,3,0)
 ;;=parent that is just now being added.
 ;;^UTILITY(U,$J,.84,308,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,308,2,1,0)
 ;;=The IENS '|IENS|' is syntactically incorrect.
 ;;^UTILITY(U,$J,.84,308,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,308,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,309,0)
 ;;=309^1^^11
 ;;^UTILITY(U,$J,.84,309,1,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,309,1,1,0)
 ;;=A multiple field is involved.  Either the root of the multiple or the 
 ;;^UTILITY(U,$J,.84,309,1,2,0)
 ;;=necessary entry numbers are missing.
 ;;^UTILITY(U,$J,.84,309,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,309,2,1,0)
 ;;=There is insufficient information to identify an entry in a subfile.
 ;;^UTILITY(U,$J,.84,310,0)
 ;;=310^1^y^11
 ;;^UTILITY(U,$J,.84,310,1,0)
 ;;=^^6^6^2940629^
 ;;^UTILITY(U,$J,.84,310,1,1,0)
 ;;=Some of the IENS subscripts in this FDA conflict with each other. For
 ;;^UTILITY(U,$J,.84,310,1,2,0)
 ;;=example, one IENS may use the sequence number ?1 while another uses +1.
 ;;^UTILITY(U,$J,.84,310,1,3,0)
 ;;=This would be illegal because the sequence number 1 is being used to
 ;;^UTILITY(U,$J,.84,310,1,4,0)
 ;;=represent two different operations. Consult your documentation for an
 ;;^UTILITY(U,$J,.84,310,1,5,0)
 ;;=explanation of the various conflicts possible. The IENS returned with this
 ;;^UTILITY(U,$J,.84,310,1,6,0)
 ;;=error happens to be one of the IENS values in conflict.
 ;;^UTILITY(U,$J,.84,310,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,310,2,1,0)
 ;;=The IENS '|IENS|' conflicts with the rest of the FDA.
 ;;^UTILITY(U,$J,.84,310,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,310,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,311,0)
 ;;=311^1^y^11
 ;;^UTILITY(U,$J,.84,311,1,0)
 ;;=^^3^3^2940629^
 ;;^UTILITY(U,$J,.84,311,1,1,0)
 ;;=Adding an entry to a file without including all required identifiers
 ;;^UTILITY(U,$J,.84,311,1,2,0)
 ;;=violates database integrity. The entry identified by this IENS lacks some
 ;;^UTILITY(U,$J,.84,311,1,3,0)
 ;;=of its required identifiers in the passed FDA.
 ;;^UTILITY(U,$J,.84,311,2,0)
 ;;=^^1^1^2941018^
 ;;^UTILITY(U,$J,.84,311,2,1,0)
 ;;=The new record '|IENS|' lacks some required identifiers.
 ;;^UTILITY(U,$J,.84,311,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,311,3,1,0)
 ;;=IENS^IENS.
 ;;^UTILITY(U,$J,.84,330,0)
 ;;=330^1^y^11
 ;;^UTILITY(U,$J,.84,330,1,0)
 ;;=^^2^2^2941123^
 ;;^UTILITY(U,$J,.84,330,1,1,0)
 ;;=The value passed by the calling application should be a certain data type,
 ;;^UTILITY(U,$J,.84,330,1,2,0)
 ;;=but according to our checks it is not.
 ;;^UTILITY(U,$J,.84,330,2,0)
 ;;=^^1^1^2941123^
 ;;^UTILITY(U,$J,.84,330,2,1,0)
 ;;=The value '|1|' is not a valid |2|.
 ;;^UTILITY(U,$J,.84,330,3,0)
 ;;=^.845^2^2

DINIT007
DINIT007 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,330,3,1,0)
 ;;=1^Passed Value.
 ;;^UTILITY(U,$J,.84,330,3,2,0)
 ;;=2^Data Type.
 ;;^UTILITY(U,$J,.84,348,0)
 ;;=348^1^y^11^
 ;;^UTILITY(U,$J,.84,348,1,0)
 ;;=^^2^2^2940214^
 ;;^UTILITY(U,$J,.84,348,1,1,0)
 ;;=The calling application passed us a variable pointer value. That value
 ;;^UTILITY(U,$J,.84,348,1,2,0)
 ;;=points to a file that does not exist, or that lacks a Header Node.
 ;;^UTILITY(U,$J,.84,348,2,0)
 ;;=^^2^2^2940214^
 ;;^UTILITY(U,$J,.84,348,2,1,0)
 ;;=The passed value '|1|' points to a file that does not exist or lacks a
 ;;^UTILITY(U,$J,.84,348,2,2,0)
 ;;=Header Node.
 ;;^UTILITY(U,$J,.84,348,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,348,3,1,0)
 ;;=1^Passed Value.
 ;;^UTILITY(U,$J,.84,349,0)
 ;;=349^2^y^11^
 ;;^UTILITY(U,$J,.84,349,1,0)
 ;;=^^2^2^2940310^^^
 ;;^UTILITY(U,$J,.84,349,1,1,0)
 ;;=Text used by the Replace...With editor
 ;;^UTILITY(U,$J,.84,349,1,2,0)
 ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!!
 ;;^UTILITY(U,$J,.84,349,2,0)
 ;;=^^1^1^2940310^^
 ;;^UTILITY(U,$J,.84,349,2,1,0)
 ;;= String too long by |1| character(s)!
 ;;^UTILITY(U,$J,.84,349,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,349,3,1,0)
 ;;=1^Number of characters over the limit.
 ;;^UTILITY(U,$J,.84,349,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,350,0)
 ;;=350^2^^11
 ;;^UTILITY(U,$J,.84,350,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,350,1,1,0)
 ;;=Message from the Replace...With editor.
 ;;^UTILITY(U,$J,.84,350,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,350,2,1,0)
 ;;= String too long! '^' to quit.
 ;;^UTILITY(U,$J,.84,350,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,351,0)
 ;;=351^1^y^11
 ;;^UTILITY(U,$J,.84,351,1,0)
 ;;=^^4^4^2941021^
 ;;^UTILITY(U,$J,.84,351,1,1,0)
 ;;=When passing an FDA to the Updater, any entries intended as Finding or
 ;;^UTILITY(U,$J,.84,351,1,2,0)
 ;;=LAYGO Finding nodes must include a .01 node that has the lookup value.
 ;;^UTILITY(U,$J,.84,351,1,3,0)
 ;;=This value need not be a legitimate .01 field value, but it must be a
 ;;^UTILITY(U,$J,.84,351,1,4,0)
 ;;=valid and unambiguous lookup value for the file.
 ;;^UTILITY(U,$J,.84,351,2,0)
 ;;=^^1^1^2941021^
 ;;^UTILITY(U,$J,.84,351,2,1,0)
 ;;=FDA nodes for lookup '|IENS|' omit a .01 node with a lookup value.
 ;;^UTILITY(U,$J,.84,351,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,351,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,351,3,2,0)
 ;;=IENS^IENS Subscript for Finding or LAYGO Finding node.
 ;;^UTILITY(U,$J,.84,401,0)
 ;;=401^1^y^11^
 ;;^UTILITY(U,$J,.84,401,1,0)
 ;;=^^2^2^2931123^^^
 ;;^UTILITY(U,$J,.84,401,1,1,0)
 ;;=The specified file or subfile does not exist; it is not present in the 
 ;;^UTILITY(U,$J,.84,401,1,2,0)
 ;;=data dictionary.
 ;;^UTILITY(U,$J,.84,401,2,0)
 ;;=^^1^1^2931123^^^
 ;;^UTILITY(U,$J,.84,401,2,1,0)
 ;;=File #|FILE| does not exist.
 ;;^UTILITY(U,$J,.84,401,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,401,3,1,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,402,0)
 ;;=402^1^y^11^
 ;;^UTILITY(U,$J,.84,402,1,0)
 ;;=^^2^2^2940316^^^^
 ;;^UTILITY(U,$J,.84,402,1,1,0)
 ;;=The specified file or subfile lacks a valid global root; the global root
 ;;^UTILITY(U,$J,.84,402,1,2,0)
 ;;=is missing or is syntactically not valid.
 ;;^UTILITY(U,$J,.84,402,2,0)
 ;;=^^1^1^2940316^^^^
 ;;^UTILITY(U,$J,.84,402,2,1,0)
 ;;=The global root of file #|FILE| is missing or not valid.
 ;;^UTILITY(U,$J,.84,402,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,402,3,1,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,402,3,2,0)
 ;;=ROOT^File root.
 ;;^UTILITY(U,$J,.84,402,3,3,0)
 ;;=IENS^IEN String.
 ;;^UTILITY(U,$J,.84,403,0)
 ;;=403^1^y^11^
 ;;^UTILITY(U,$J,.84,403,1,0)
 ;;=^^3^3^2940213^
 ;;^UTILITY(U,$J,.84,403,1,1,0)
 ;;=The File Header Node, the top level of the data file as described in the
 ;;^UTILITY(U,$J,.84,403,1,2,0)
 ;;=Programmer Manual, must be present for FileMan to determine certain kinds
 ;;^UTILITY(U,$J,.84,403,1,3,0)
 ;;=of information about a file.
 ;;^UTILITY(U,$J,.84,403,2,0)
 ;;=^^1^1^2940213^
 ;;^UTILITY(U,$J,.84,403,2,1,0)
 ;;=File #|FILE| lacks a Header Node.
 ;;^UTILITY(U,$J,.84,403,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,403,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,404,0)
 ;;=404^1^y^11^
 ;;^UTILITY(U,$J,.84,404,1,0)
 ;;=^^4^4^2940214^
 ;;^UTILITY(U,$J,.84,404,1,1,0)
 ;;=We have identified a file by the global node of its data file, and found
 ;;^UTILITY(U,$J,.84,404,1,2,0)
 ;;=its Header Node. We needed to use the Header Node to identify the number

DINIT008
DINIT008 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,404,1,3,0)
 ;;=of the file, but that piece of information is missing from the Header
 ;;^UTILITY(U,$J,.84,404,1,4,0)
 ;;=Node.
 ;;^UTILITY(U,$J,.84,404,2,0)
 ;;=^^1^1^2940214^
 ;;^UTILITY(U,$J,.84,404,2,1,0)
 ;;=The File Header node of the file stored at |1| lacks a file number.
 ;;^UTILITY(U,$J,.84,404,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,404,3,1,0)
 ;;=1^File Root.
 ;;^UTILITY(U,$J,.84,405,0)
 ;;=405^1^y^11^
 ;;^UTILITY(U,$J,.84,405,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,405,1,1,0)
 ;;=The NO EDIT flag is set for the file.  No instruction to override
 ;;^UTILITY(U,$J,.84,405,1,2,0)
 ;;=that flag is present.
 ;;^UTILITY(U,$J,.84,405,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,405,2,1,0)
 ;;=Entries in file |1| cannot be edited.
 ;;^UTILITY(U,$J,.84,405,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,405,3,1,0)
 ;;=1^File Name.
 ;;^UTILITY(U,$J,.84,405,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,406,0)
 ;;=406^1^y^11^
 ;;^UTILITY(U,$J,.84,406,1,0)
 ;;=^^2^2^2940317^
 ;;^UTILITY(U,$J,.84,406,1,1,0)
 ;;=The data definition for a .01 field for the specified file is missing.
 ;;^UTILITY(U,$J,.84,406,1,2,0)
 ;;=This file is therefore not valid for most database operations.
 ;;^UTILITY(U,$J,.84,406,2,0)
 ;;=^^1^1^2940317^
 ;;^UTILITY(U,$J,.84,406,2,1,0)
 ;;=File #|FILE| has no .01 field definition.
 ;;^UTILITY(U,$J,.84,406,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,406,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,407,0)
 ;;=407^1^^11
 ;;^UTILITY(U,$J,.84,407,1,0)
 ;;=^^4^4^2940317^
 ;;^UTILITY(U,$J,.84,407,1,1,0)
 ;;=The subfile number of a word processing field has been passed in the place
 ;;^UTILITY(U,$J,.84,407,1,2,0)
 ;;=of a file parameter. This is not acceptable. Although we implement word
 ;;^UTILITY(U,$J,.84,407,1,3,0)
 ;;=processing fields as independent files, we do not allow them to be treated
 ;;^UTILITY(U,$J,.84,407,1,4,0)
 ;;=as files for purposes of most database activities.
 ;;^UTILITY(U,$J,.84,407,2,0)
 ;;=^^1^1^2940317^
 ;;^UTILITY(U,$J,.84,407,2,1,0)
 ;;=A word-processing field is not a file.
 ;;^UTILITY(U,$J,.84,407,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,407,3,1,0)
 ;;=FILE^Subfile # of word-processing field.
 ;;^UTILITY(U,$J,.84,408,0)
 ;;=408^1^y^11
 ;;^UTILITY(U,$J,.84,408,1,0)
 ;;=^^2^2^2940715^
 ;;^UTILITY(U,$J,.84,408,1,1,0)
 ;;=The file lacks a name. For subfiles, $P(^DD(file#,0),U) is null. For root
 ;;^UTILITY(U,$J,.84,408,1,2,0)
 ;;=files, $O(^DD(file#,0,"NM",""))="". 
 ;;^UTILITY(U,$J,.84,408,2,0)
 ;;=^^1^1^2940715^
 ;;^UTILITY(U,$J,.84,408,2,1,0)
 ;;=File# |FILE| lacks a name.
 ;;^UTILITY(U,$J,.84,408,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,408,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,420,0)
 ;;=420^1^y^11^
 ;;^UTILITY(U,$J,.84,420,1,0)
 ;;=^^4^4^2940628^
 ;;^UTILITY(U,$J,.84,420,1,1,0)
 ;;=A cross reference was specified for look-up, but that cross reference 
 ;;^UTILITY(U,$J,.84,420,1,2,0)
 ;;=does not exist on the file. The file has entries, but the index does not.
 ;;^UTILITY(U,$J,.84,420,1,3,0)
 ;;=This error implies nothing about whether the index is defined in the
 ;;^UTILITY(U,$J,.84,420,1,4,0)
 ;;=file's DD.
 ;;^UTILITY(U,$J,.84,420,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,420,2,1,0)
 ;;=There is no |1| index for File #|FILE|.
 ;;^UTILITY(U,$J,.84,420,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,420,3,1,0)
 ;;=1^Cross reference name.
 ;;^UTILITY(U,$J,.84,420,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,501,0)
 ;;=501^1^y^11^
 ;;^UTILITY(U,$J,.84,501,1,0)
 ;;=^^2^2^2940214^^^
 ;;^UTILITY(U,$J,.84,501,1,1,0)
 ;;=A search of the data dictionary reveals that the field name or number
 ;;^UTILITY(U,$J,.84,501,1,2,0)
 ;;=passed does not exist in the specified file.
 ;;^UTILITY(U,$J,.84,501,2,0)
 ;;=^^1^1^2940214^^
 ;;^UTILITY(U,$J,.84,501,2,1,0)
 ;;=File #|FILE| does not contain a field |1|.
 ;;^UTILITY(U,$J,.84,501,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,501,3,1,0)
 ;;=1^Field name or number.
 ;;^UTILITY(U,$J,.84,501,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,501,3,3,0)
 ;;=FIELD^Field number.
 ;;^UTILITY(U,$J,.84,502,0)
 ;;=502^1^y^11
 ;;^UTILITY(U,$J,.84,502,1,0)
 ;;=^^3^3^2940715^
 ;;^UTILITY(U,$J,.84,502,1,1,0)
 ;;=The field has been identified, but some key part of its definition is
 ;;^UTILITY(U,$J,.84,502,1,2,0)
 ;;=missing or corrupted. ^DD(file#,field#,0) may not be defined. Some key
 ;;^UTILITY(U,$J,.84,502,1,3,0)
 ;;=piece of that node may be missing.

DINIT009
DINIT009 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,502,2,0)
 ;;=^^1^1^2940715^
 ;;^UTILITY(U,$J,.84,502,2,1,0)
 ;;=Field# |FIELD| in file# |FILE| has a corrupted definition.
 ;;^UTILITY(U,$J,.84,502,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,502,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,502,3,2,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,505,0)
 ;;=505^1^y^11^
 ;;^UTILITY(U,$J,.84,505,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,505,1,1,0)
 ;;=The field name passed is ambiguous.  It cannot be determined to which field
 ;;^UTILITY(U,$J,.84,505,1,2,0)
 ;;=in the file it refers.
 ;;^UTILITY(U,$J,.84,505,2,0)
 ;;=^^1^1^2931116^^
 ;;^UTILITY(U,$J,.84,505,2,1,0)
 ;;=There is more than one field named '|1|' in File #|FILE|.
 ;;^UTILITY(U,$J,.84,505,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,505,3,1,0)
 ;;=1^Field name.
 ;;^UTILITY(U,$J,.84,505,3,2,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,510,0)
 ;;=510^1^y^11^
 ;;^UTILITY(U,$J,.84,510,1,0)
 ;;=^^2^2^2940214^^^^
 ;;^UTILITY(U,$J,.84,510,1,1,0)
 ;;=For some reason, the data type for the specified field cannot be determined.
 ;;^UTILITY(U,$J,.84,510,1,2,0)
 ;;=This may mean that the data dictionary is corrupted.
 ;;^UTILITY(U,$J,.84,510,2,0)
 ;;=^^1^1^2940214^^
 ;;^UTILITY(U,$J,.84,510,2,1,0)
 ;;=The data type for Field #|FIELD| in File #|FILE| cannot be determined.
 ;;^UTILITY(U,$J,.84,510,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,510,3,1,0)
 ;;=FIELD^Field number.
 ;;^UTILITY(U,$J,.84,510,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,520,0)
 ;;=520^1^y^11^
 ;;^UTILITY(U,$J,.84,520,1,0)
 ;;=^^3^3^2931110^^
 ;;^UTILITY(U,$J,.84,520,1,1,0)
 ;;=An incorrect kind of field is being processed.  For example, filing is 
 ;;^UTILITY(U,$J,.84,520,1,2,0)
 ;;=being attempted for a computed field or validation for a word
 ;;^UTILITY(U,$J,.84,520,1,3,0)
 ;;=processing field.
 ;;^UTILITY(U,$J,.84,520,2,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,520,2,1,0)
 ;;=A |1| field cannot be processed by this utility.
 ;;^UTILITY(U,$J,.84,520,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,520,3,1,0)
 ;;=1^Data type or other field characteristic (e.g., .001, DINUMed).
 ;;^UTILITY(U,$J,.84,520,3,2,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,520,3,3,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,520,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,520,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,537,0)
 ;;=537^1^y^11^
 ;;^UTILITY(U,$J,.84,537,1,0)
 ;;=^^7^7^2940213^
 ;;^UTILITY(U,$J,.84,537,1,1,0)
 ;;=This error means that a certain field in a certain file has a data type of
 ;;^UTILITY(U,$J,.84,537,1,2,0)
 ;;=pointer, but something is wrong with the rest of the DD info needed to
 ;;^UTILITY(U,$J,.84,537,1,3,0)
 ;;=make that pointer work. For example, perhaps the number of the pointed to
 ;;^UTILITY(U,$J,.84,537,1,4,0)
 ;;=file, which should follow the P in the second ^-piece of the field
 ;;^UTILITY(U,$J,.84,537,1,5,0)
 ;;=descriptor node, is missing. Another problem would be if the global root
 ;;^UTILITY(U,$J,.84,537,1,6,0)
 ;;=of the pointed to file were missing from the field's definition; that
 ;;^UTILITY(U,$J,.84,537,1,7,0)
 ;;=should be found in the third ^-piece of the field descriptor.
 ;;^UTILITY(U,$J,.84,537,2,0)
 ;;=^^1^1^2940213^
 ;;^UTILITY(U,$J,.84,537,2,1,0)
 ;;=Field #|FIELD| in File #|FILE| has a corrupted pointer definition.
 ;;^UTILITY(U,$J,.84,537,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,537,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,537,3,2,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,601,0)
 ;;=601^1^^11
 ;;^UTILITY(U,$J,.84,601,1,0)
 ;;=^^1^1^2940426^
 ;;^UTILITY(U,$J,.84,601,1,1,0)
 ;;=The entry identified by FILE and IENS does not exist in the database.
 ;;^UTILITY(U,$J,.84,601,2,0)
 ;;=^^1^1^2940426^^
 ;;^UTILITY(U,$J,.84,601,2,1,0)
 ;;=The entry does not exist.
 ;;^UTILITY(U,$J,.84,601,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,601,3,1,0)
 ;;=FILE^File or subfile #. (external only)
 ;;^UTILITY(U,$J,.84,601,3,2,0)
 ;;=IENS^IEN string (external only)
 ;;^UTILITY(U,$J,.84,602,0)
 ;;=602^1^^11
 ;;^UTILITY(U,$J,.84,602,1,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,602,1,1,0)
 ;;=There is a -9 node for the entry; therefore, the entry cannot be accessed.
 ;;^UTILITY(U,$J,.84,602,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,602,2,1,0)
 ;;=The entry is not available for editing.
 ;;^UTILITY(U,$J,.84,602,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,602,3,1,0)
 ;;=FILE^File or subfile #. (external only)
 ;;^UTILITY(U,$J,.84,602,3,2,0)
 ;;=IENS^IEN string. (external only)

DINIT00A
DINIT00A ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,603,0)
 ;;=603^1^y^11^
 ;;^UTILITY(U,$J,.84,603,1,0)
 ;;=^^2^2^2940214^
 ;;^UTILITY(U,$J,.84,603,1,1,0)
 ;;=A specific entry in a specific file lacks a value for a required field.
 ;;^UTILITY(U,$J,.84,603,1,2,0)
 ;;=This error message returns which field is missing.
 ;;^UTILITY(U,$J,.84,603,2,0)
 ;;=^^1^1^2940214^
 ;;^UTILITY(U,$J,.84,603,2,1,0)
 ;;=Entry #|1| in File #|FILE| lacks the required Field #|FIELD|.
 ;;^UTILITY(U,$J,.84,603,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,603,3,1,0)
 ;;=1^Entry #.
 ;;^UTILITY(U,$J,.84,603,3,2,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,603,3,3,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,630,0)
 ;;=630^1^y^11
 ;;^UTILITY(U,$J,.84,630,1,0)
 ;;=^^2^2^2941128^
 ;;^UTILITY(U,$J,.84,630,1,1,0)
 ;;=The database is corrupted. The value for a specific field in one entry
 ;;^UTILITY(U,$J,.84,630,1,2,0)
 ;;=should be a certain data type, but it is not.
 ;;^UTILITY(U,$J,.84,630,2,0)
 ;;=^^2^2^2941128^
 ;;^UTILITY(U,$J,.84,630,2,1,0)
 ;;=In Entry #|1| of File #|FILE|, the value '|2|' for Field #|FIELD| is not a
 ;;^UTILITY(U,$J,.84,630,2,2,0)
 ;;=valid |3|.
 ;;^UTILITY(U,$J,.84,630,3,0)
 ;;=^.845^5^5
 ;;^UTILITY(U,$J,.84,630,3,1,0)
 ;;=1^Entry #.
 ;;^UTILITY(U,$J,.84,630,3,2,0)
 ;;=2^Field Value.
 ;;^UTILITY(U,$J,.84,630,3,3,0)
 ;;=3^Data Type.
 ;;^UTILITY(U,$J,.84,630,3,4,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,630,3,5,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,648,0)
 ;;=648^1^y^11^
 ;;^UTILITY(U,$J,.84,648,1,0)
 ;;=^^3^3^2940214^
 ;;^UTILITY(U,$J,.84,648,1,1,0)
 ;;=The database is corrupted. In a specific variable pointer field of a
 ;;^UTILITY(U,$J,.84,648,1,2,0)
 ;;=certain entry, the field's value points to a file that either does not
 ;;^UTILITY(U,$J,.84,648,1,3,0)
 ;;=exist or that lacks a Header Node.
 ;;^UTILITY(U,$J,.84,648,2,0)
 ;;=^^2^2^2940214^
 ;;^UTILITY(U,$J,.84,648,2,1,0)
 ;;=In Entry #|1| of File #|FILE|, the value '|2|' for Field #|FIELD| points
 ;;^UTILITY(U,$J,.84,648,2,2,0)
 ;;=to a file that does not exist or lacks a Header Node.
 ;;^UTILITY(U,$J,.84,648,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,648,3,1,0)
 ;;=1^Entry #.
 ;;^UTILITY(U,$J,.84,648,3,2,0)
 ;;=2^Field Value.
 ;;^UTILITY(U,$J,.84,648,3,3,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,648,3,4,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,701,0)
 ;;=701^1^y^11^
 ;;^UTILITY(U,$J,.84,701,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,701,1,1,0)
 ;;=The value is invalid.  Possible causes include:  value did not pass input 
 ;;^UTILITY(U,$J,.84,701,1,2,0)
 ;;=transform, value for a pointer or variable pointer field cannot be found in 
 ;;^UTILITY(U,$J,.84,701,1,3,0)
 ;;=the pointed-to file, a screen was not passed.
 ;;^UTILITY(U,$J,.84,701,2,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,701,2,1,0)
 ;;=The value '|3|' for field |1| in file |2| is not valid.
 ;;^UTILITY(U,$J,.84,701,3,0)
 ;;=^.845^6^6
 ;;^UTILITY(U,$J,.84,701,3,1,0)
 ;;=1^Field name.
 ;;^UTILITY(U,$J,.84,701,3,2,0)
 ;;=2^File name.
 ;;^UTILITY(U,$J,.84,701,3,3,0)
 ;;=3^Value that was found to be invalid.
 ;;^UTILITY(U,$J,.84,701,3,4,0)
 ;;=FIELD^Field number. (external only)
 ;;^UTILITY(U,$J,.84,701,3,5,0)
 ;;=FILE^File number.  (external only)
 ;;^UTILITY(U,$J,.84,701,3,6,0)
 ;;=IENS^IEN string identifying entry with invalid value. (external only, sometimes returned)
 ;;^UTILITY(U,$J,.84,701,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,701,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,703,0)
 ;;=703^1^y^11^
 ;;^UTILITY(U,$J,.84,703,1,0)
 ;;=^^1^1^2940317^
 ;;^UTILITY(U,$J,.84,703,1,1,0)
 ;;=The value passed cannot be found in the indicated file using $$FIND1^DIC.
 ;;^UTILITY(U,$J,.84,703,2,0)
 ;;=^^1^1^2940317^
 ;;^UTILITY(U,$J,.84,703,2,1,0)
 ;;=The value '|1|' cannot be found in file #|FILE|.
 ;;^UTILITY(U,$J,.84,703,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,703,3,1,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,703,3,2,0)
 ;;=IENS^IEN String.
 ;;^UTILITY(U,$J,.84,703,3,3,0)
 ;;=1^Lookup Value.
 ;;^UTILITY(U,$J,.84,710,0)
 ;;=710^1^y^11^
 ;;^UTILITY(U,$J,.84,710,1,0)
 ;;=^^2^2^2931123^^^^
 ;;^UTILITY(U,$J,.84,710,1,1,0)
 ;;=The data dictionary specifies that the field is uneditable.  Data already
 ;;^UTILITY(U,$J,.84,710,1,2,0)
 ;;=exists in the field.  It cannot be changed.
 ;;^UTILITY(U,$J,.84,710,2,0)
 ;;=^^1^1^2931110^^^
 ;;^UTILITY(U,$J,.84,710,2,1,0)
 ;;=Data in Field #|FIELD| in File #|FILE| cannot be edited.
 ;;^UTILITY(U,$J,.84,710,3,0)
 ;;=^.845^2^2

DINIT00B
DINIT00B ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,710,3,1,0)
 ;;=FIELD^Field number.
 ;;^UTILITY(U,$J,.84,710,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,712,0)
 ;;=712^1^y^11^
 ;;^UTILITY(U,$J,.84,712,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,712,1,1,0)
 ;;=The value of a field cannot be deleted either because it is a required 
 ;;^UTILITY(U,$J,.84,712,1,2,0)
 ;;=field, because it is the .01 of a file, or because the test in the "DEL"
 ;;^UTILITY(U,$J,.84,712,1,3,0)
 ;;=node was not passed.
 ;;^UTILITY(U,$J,.84,712,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,712,2,1,0)
 ;;=The value of field |1| in file |2| cannot be deleted.
 ;;^UTILITY(U,$J,.84,712,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,712,3,1,0)
 ;;=1^Field name.
 ;;^UTILITY(U,$J,.84,712,3,2,0)
 ;;=2^File name.
 ;;^UTILITY(U,$J,.84,712,3,3,0)
 ;;=FIELD^Field number.  (external only)
 ;;^UTILITY(U,$J,.84,712,3,4,0)
 ;;=FILE^File number.  (external only)
 ;;^UTILITY(U,$J,.84,712,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,712,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,714,0)
 ;;=714^1^y^11^
 ;;^UTILITY(U,$J,.84,714,1,0)
 ;;=^^2^2^2931109^^
 ;;^UTILITY(U,$J,.84,714,1,1,0)
 ;;=The field uses $Piece storage and the data contains an '^'.  The data
 ;;^UTILITY(U,$J,.84,714,1,2,0)
 ;;=cannot be filed.
 ;;^UTILITY(U,$J,.84,714,2,0)
 ;;=^^1^1^2931109^^
 ;;^UTILITY(U,$J,.84,714,2,1,0)
 ;;=Data for Field |1| in File |2| contains an '^'.
 ;;^UTILITY(U,$J,.84,714,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,714,3,1,0)
 ;;=1^Field name.
 ;;^UTILITY(U,$J,.84,714,3,2,0)
 ;;=2^File name.
 ;;^UTILITY(U,$J,.84,714,3,3,0)
 ;;=FILE^File number.  (external only)
 ;;^UTILITY(U,$J,.84,714,3,4,0)
 ;;=FIELD^Field number. (external only)
 ;;^UTILITY(U,$J,.84,714,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,714,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,716,0)
 ;;=716^1^y^11^
 ;;^UTILITY(U,$J,.84,716,1,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,716,1,1,0)
 ;;=Data being filed is too long for the field.  Specifically, this occurs 
 ;;^UTILITY(U,$J,.84,716,1,2,0)
 ;;=when data of the wrong length is being filed in a $Extract (Em,n) field.
 ;;^UTILITY(U,$J,.84,716,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,716,2,1,0)
 ;;=Data for field |1| in file |2| is too long.
 ;;^UTILITY(U,$J,.84,716,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,716,3,1,0)
 ;;=1^Field name.
 ;;^UTILITY(U,$J,.84,716,3,2,0)
 ;;=2^File name.
 ;;^UTILITY(U,$J,.84,716,3,3,0)
 ;;=FIELD^Field number. (external only)
 ;;^UTILITY(U,$J,.84,716,3,4,0)
 ;;=FILE^File number.  (external only)
 ;;^UTILITY(U,$J,.84,716,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,716,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,720,0)
 ;;=720^1^^11
 ;;^UTILITY(U,$J,.84,720,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,720,1,1,0)
 ;;=The lookup for a pointer fails.  This is an error only when
 ;;^UTILITY(U,$J,.84,720,1,2,0)
 ;;=LAYGO is not allowed.
 ;;^UTILITY(U,$J,.84,720,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,720,2,1,0)
 ;;=The value cannot be found in the pointed-to file.
 ;;^UTILITY(U,$J,.84,720,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,720,3,1,0)
 ;;=FILE^File number -- the number of the file in which the pointer field exists.
 ;;^UTILITY(U,$J,.84,720,3,2,0)
 ;;=FIELD^Field number of the pointer field.
 ;;^UTILITY(U,$J,.84,726,0)
 ;;=726^1^y^11^
 ;;^UTILITY(U,$J,.84,726,1,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,726,1,1,0)
 ;;=There is an attempt to take an action with word processing data, but
 ;;^UTILITY(U,$J,.84,726,1,2,0)
 ;;=the specified field is not a word processing field.
 ;;^UTILITY(U,$J,.84,726,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,726,2,1,0)
 ;;=Field #|FIELD| in File #|FILE| is not a word processing field.
 ;;^UTILITY(U,$J,.84,726,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,726,3,1,0)
 ;;=FIELD^Field number.
 ;;^UTILITY(U,$J,.84,726,3,2,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,730,0)
 ;;=730^1^y^11^
 ;;^UTILITY(U,$J,.84,730,1,0)
 ;;=^^2^2^2941128^
 ;;^UTILITY(U,$J,.84,730,1,1,0)
 ;;=Based on how the data type is defined by a specific field in a specific
 ;;^UTILITY(U,$J,.84,730,1,2,0)
 ;;=file, the passed value is not valid.
 ;;^UTILITY(U,$J,.84,730,2,0)
 ;;=^^2^2^2941128^
 ;;^UTILITY(U,$J,.84,730,2,1,0)
 ;;=The value '|1|' is not a valid |2| according to the definition in Field
 ;;^UTILITY(U,$J,.84,730,2,2,0)
 ;;=#|FIELD| of File #|FILE|.
 ;;^UTILITY(U,$J,.84,730,3,0)
 ;;=^.845^4^4
 ;;^UTILITY(U,$J,.84,730,3,1,0)
 ;;=1^Passed Value.
 ;;^UTILITY(U,$J,.84,730,3,2,0)
 ;;=2^Data Type.

DINIT00C
DINIT00C ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,730,3,3,0)
 ;;=FIELD^Field #.
 ;;^UTILITY(U,$J,.84,730,3,4,0)
 ;;=FILE^File #.
 ;;^UTILITY(U,$J,.84,810,0)
 ;;=810^1^^11
 ;;^UTILITY(U,$J,.84,810,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,810,1,1,0)
 ;;=A %ZOSF node required to perform a function does not exist.  The
 ;;^UTILITY(U,$J,.84,810,1,2,0)
 ;;=VA FileMan Programmer's Manual contains a complete list of %ZOSF
 ;;^UTILITY(U,$J,.84,810,1,3,0)
 ;;=nodes.
 ;;^UTILITY(U,$J,.84,810,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,810,2,1,0)
 ;;=A necessary %ZOSF node does not exist on your system.
 ;;^UTILITY(U,$J,.84,820,0)
 ;;=820^1^^11
 ;;^UTILITY(U,$J,.84,820,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,820,1,1,0)
 ;;=The ZSAVE CODE field (#2619) in the MUMPS Operating System file (#.7)
 ;;^UTILITY(U,$J,.84,820,1,2,0)
 ;;=is empty for the operating system being used.  It is impossible to perform
 ;;^UTILITY(U,$J,.84,820,1,3,0)
 ;;=functions such as compiling templates or cross references.
 ;;^UTILITY(U,$J,.84,820,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,820,2,1,0)
 ;;=There is no way to save routines on the system.
 ;;^UTILITY(U,$J,.84,840,0)
 ;;=840^1^y^11^
 ;;^UTILITY(U,$J,.84,840,1,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,840,1,1,0)
 ;;=The Terminal Type file does not have an entry that matches IOST(0).
 ;;^UTILITY(U,$J,.84,840,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,840,2,1,0)
 ;;=Terminal type '|1|' cannot be found in the Terminal Type file.
 ;;^UTILITY(U,$J,.84,840,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,840,3,1,0)
 ;;=1^Terminal type as identified by IOST(0).
 ;;^UTILITY(U,$J,.84,842,0)
 ;;=842^1^y^11^
 ;;^UTILITY(U,$J,.84,842,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,842,1,1,0)
 ;;=The field in the Terminal Type field that contains the specified
 ;;^UTILITY(U,$J,.84,842,1,2,0)
 ;;=characteristic of the terminal is null.
 ;;^UTILITY(U,$J,.84,842,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,842,2,1,0)
 ;;=|1| cannot be found for Terminal Type |2|.
 ;;^UTILITY(U,$J,.84,842,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,842,3,1,0)
 ;;=1^Terminal Type characteristic.
 ;;^UTILITY(U,$J,.84,842,3,2,0)
 ;;=2^Terminal type.
 ;;^UTILITY(U,$J,.84,845,0)
 ;;=845^1^^11
 ;;^UTILITY(U,$J,.84,845,1,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,845,1,1,0)
 ;;=A %ZIS call with IOP set to "HOME" returns POP.
 ;;^UTILITY(U,$J,.84,845,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,845,2,1,0)
 ;;=The characteristics for the HOME device cannot be obtained.
 ;;^UTILITY(U,$J,.84,1500,0)
 ;;=1500^1^y^11^
 ;;^UTILITY(U,$J,.84,1500,1,0)
 ;;=^^2^2^2931112^
 ;;^UTILITY(U,$J,.84,1500,1,1,0)
 ;;=Error given for unsuccessful lookup of search template in BY(0) input
 ;;^UTILITY(U,$J,.84,1500,1,2,0)
 ;;=variable.
 ;;^UTILITY(U,$J,.84,1500,2,0)
 ;;=^^2^2^2931112^
 ;;^UTILITY(U,$J,.84,1500,2,1,0)
 ;;=Search template |1| in BY(0) variable cannot be found,
 ;;^UTILITY(U,$J,.84,1500,2,2,0)
 ;;=is for the wrong file, or has no list of search results.
 ;;^UTILITY(U,$J,.84,1500,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,1500,3,1,0)
 ;;=1^Name of search template in input variable BY(0).
 ;;^UTILITY(U,$J,.84,1500,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,1500,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,1500,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,1501,0)
 ;;=1501^1^^11
 ;;^UTILITY(U,$J,.84,1501,1,0)
 ;;=^^2^2^2931116^^^
 ;;^UTILITY(U,$J,.84,1501,1,1,0)
 ;;=Error message shown to user when no code was generated during compilation
 ;;^UTILITY(U,$J,.84,1501,1,2,0)
 ;;=of SORT TEMPLATES.
 ;;^UTILITY(U,$J,.84,1501,2,0)
 ;;=^^1^1^2931116^
 ;;^UTILITY(U,$J,.84,1501,2,1,0)
 ;;=There is no code to save for this compiled Sort Template routine.
 ;;^UTILITY(U,$J,.84,1501,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,1501,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,1502,0)
 ;;=1502^1^^11
 ;;^UTILITY(U,$J,.84,1502,1,0)
 ;;=^^3^3^2931116^^^
 ;;^UTILITY(U,$J,.84,1502,1,1,0)
 ;;=Error message notifying the user that there are no more available
 ;;^UTILITY(U,$J,.84,1502,1,2,0)
 ;;=routine numbers for compiled sort template routines.  This should
 ;;^UTILITY(U,$J,.84,1502,1,3,0)
 ;;=never happen, since routine numbers are re-used.
 ;;^UTILITY(U,$J,.84,1502,2,0)
 ;;=^^2^2^2940909^
 ;;^UTILITY(U,$J,.84,1502,2,1,0)
 ;;=All available routine numbers for compilation are in use.
 ;;^UTILITY(U,$J,.84,1502,2,2,0)
 ;;=IRM needs to run ENRLS^DIOZ() to release the routine numbers.
 ;;^UTILITY(U,$J,.84,1502,5,0)
 ;;=^.841^1^1

DINIT00D
DINIT00D ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,1502,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,1503,0)
 ;;=1503^1^y^11^
 ;;^UTILITY(U,$J,.84,1503,1,0)
 ;;=^^1^1^2931116^^^^
 ;;^UTILITY(U,$J,.84,1503,1,1,0)
 ;;=Warn user to shorten compiled cross-reference routine name.
 ;;^UTILITY(U,$J,.84,1503,2,0)
 ;;=^^1^1^2931116^^
 ;;^UTILITY(U,$J,.84,1503,2,1,0)
 ;;= routine name is too long.  Compilation has been aborted.
 ;;^UTILITY(U,$J,.84,1503,5,0)
 ;;=^.841^6^6
 ;;^UTILITY(U,$J,.84,1503,5,1,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,1503,5,2,0)
 ;;=DIEZ^EN
 ;;^UTILITY(U,$J,.84,1503,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,1503,5,4,0)
 ;;=DIKZ^EN
 ;;^UTILITY(U,$J,.84,1503,5,5,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,1503,5,6,0)
 ;;=DIPZ^EN
 ;;^UTILITY(U,$J,.84,1504,0)
 ;;=1504^1^^11
 ;;^UTILITY(U,$J,.84,1504,1,0)
 ;;=^^2^2^2940316^
 ;;^UTILITY(U,$J,.84,1504,1,1,0)
 ;;=If doing Transfer/Merge of a single record from one file to another, and
 ;;^UTILITY(U,$J,.84,1504,1,2,0)
 ;;=the .01 field names do not match, we cannot do the transfer/merge.
 ;;^UTILITY(U,$J,.84,1504,2,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,1504,2,1,0)
 ;;=No matching .01 field names found.  Transfer/Merge cannot be done.
 ;;^UTILITY(U,$J,.84,1504,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,1504,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,1610,0)
 ;;=1610^1^^11
 ;;^UTILITY(U,$J,.84,1610,1,0)
 ;;=^^2^2^2940223^^
 ;;^UTILITY(U,$J,.84,1610,1,1,0)
 ;;=A question mark or, in the case of a variable pointer field, a <something>.?
 ;;^UTILITY(U,$J,.84,1610,1,2,0)
 ;;=was passed to the Validator.  The Validator does not process help requests.
 ;;^UTILITY(U,$J,.84,1610,2,0)
 ;;=^^1^1^2940223^^^
 ;;^UTILITY(U,$J,.84,1610,2,1,0)
 ;;=Help is being requested from the Validator utility.
 ;;^UTILITY(U,$J,.84,1610,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,1610,3,1,0)
 ;;=FILE^File number.
 ;;^UTILITY(U,$J,.84,1610,3,2,0)
 ;;=FIELD^Field number.
 ;;^UTILITY(U,$J,.84,1610,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,1610,5,1,0)
 ;;=DIE^FILE
 ;;^UTILITY(U,$J,.84,1700,0)
 ;;=1700^1^y^11^
 ;;^UTILITY(U,$J,.84,1700,1,0)
 ;;=^^1^1^2940310^^
 ;;^UTILITY(U,$J,.84,1700,1,1,0)
 ;;=Generic message for Silent DIFROM
 ;;^UTILITY(U,$J,.84,1700,2,0)
 ;;=^^1^1^2940310^^
 ;;^UTILITY(U,$J,.84,1700,2,1,0)
 ;;=Error: |1|.
 ;;^UTILITY(U,$J,.84,1700,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,1700,3,1,0)
 ;;=1^Generic message
 ;;^UTILITY(U,$J,.84,1701,0)
 ;;=1701^1^y^11^
 ;;^UTILITY(U,$J,.84,1701,1,0)
 ;;=^^1^1^2940912^^^
 ;;^UTILITY(U,$J,.84,1701,1,1,0)
 ;;=Transport structure does not contain SPECIFIC ELEMENT.
 ;;^UTILITY(U,$J,.84,1701,2,0)
 ;;=^^1^1^2940912^^^
 ;;^UTILITY(U,$J,.84,1701,2,1,0)
 ;;=Transport structure does not contain |1|.
 ;;^UTILITY(U,$J,.84,1701,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,1701,3,1,0)
 ;;=1^Describes missing element in transport structure.
 ;;^UTILITY(U,$J,.84,3000,0)
 ;;=3000^1^^11
 ;;^UTILITY(U,$J,.84,3000,1,0)
 ;;=^^1^1^2930721^
 ;;^UTILITY(U,$J,.84,3000,1,1,0)
 ;;=Initial call to ^DDS failed.
 ;;^UTILITY(U,$J,.84,3000,2,0)
 ;;=^^1^1^2931202^
 ;;^UTILITY(U,$J,.84,3000,2,1,0)
 ;;=THE FORM COULD NOT BE INVOKED.
 ;;^UTILITY(U,$J,.84,3002,0)
 ;;=3002^1^y^11^
 ;;^UTILITY(U,$J,.84,3002,1,0)
 ;;=^^1^1^2931202^
 ;;^UTILITY(U,$J,.84,3002,1,1,0)
 ;;=An error was encountered during Form compilation.
 ;;^UTILITY(U,$J,.84,3002,2,0)
 ;;=^^1^1^2931202^^
 ;;^UTILITY(U,$J,.84,3002,2,1,0)
 ;;=THE FORM "|1|" COULD NOT BE COMPILED.
 ;;^UTILITY(U,$J,.84,3002,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3002,3,1,0)
 ;;=1^Form name
 ;;^UTILITY(U,$J,.84,3011,0)
 ;;=3011^1^y^11^
 ;;^UTILITY(U,$J,.84,3011,1,0)
 ;;=^^1^1^2931201^
 ;;^UTILITY(U,$J,.84,3011,1,1,0)
 ;;=The specified field is missing or invalid.
 ;;^UTILITY(U,$J,.84,3011,2,0)
 ;;=^^1^1^2931201^
 ;;^UTILITY(U,$J,.84,3011,2,1,0)
 ;;=The |1| field of the |2| file is missing or invalid.
 ;;^UTILITY(U,$J,.84,3011,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,3011,3,1,0)
 ;;=1^Field or subfield name
 ;;^UTILITY(U,$J,.84,3011,3,2,0)
 ;;=2^File name
 ;;^UTILITY(U,$J,.84,3012,0)
 ;;=3012^1^y^11^
 ;;^UTILITY(U,$J,.84,3012,1,0)
 ;;=^^2^2^2931201^
 ;;^UTILITY(U,$J,.84,3012,1,1,0)
 ;;=The specified file or subfile does not exist; it is not present in the
 ;;^UTILITY(U,$J,.84,3012,1,2,0)
 ;;=data dictionary.
 ;;^UTILITY(U,$J,.84,3012,2,0)
 ;;=^^1^1^2931201^
 ;;^UTILITY(U,$J,.84,3012,2,1,0)
 ;;=File |1| does not exist.
 ;;^UTILITY(U,$J,.84,3012,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3012,3,1,0)
 ;;=1^File number or name

DINIT00E
DINIT00E ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,3021,0)
 ;;=3021^1^y^11^
 ;;^UTILITY(U,$J,.84,3021,1,0)
 ;;=^^1^1^2940811^^^
 ;;^UTILITY(U,$J,.84,3021,1,1,0)
 ;;=A lookup in to the Form file for the given form failed.
 ;;^UTILITY(U,$J,.84,3021,2,0)
 ;;=^^2^2^2940811^
 ;;^UTILITY(U,$J,.84,3021,2,1,0)
 ;;=Form |1| does not exist in the Form file, or DDSFILE is not the Primary
 ;;^UTILITY(U,$J,.84,3021,2,2,0)
 ;;=File of the form.
 ;;^UTILITY(U,$J,.84,3021,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3021,3,1,0)
 ;;=1^Form name
 ;;^UTILITY(U,$J,.84,3022,0)
 ;;=3022^1^y^11^
 ;;^UTILITY(U,$J,.84,3022,1,0)
 ;;=^^1^1^2931130^^
 ;;^UTILITY(U,$J,.84,3022,1,1,0)
 ;;=There are no pages defined in the Page multiple of the given form.
 ;;^UTILITY(U,$J,.84,3022,2,0)
 ;;=^^1^1^2931130^^
 ;;^UTILITY(U,$J,.84,3022,2,1,0)
 ;;=Form |1| contains no pages.
 ;;^UTILITY(U,$J,.84,3022,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3022,3,1,0)
 ;;=1^Form name
 ;;^UTILITY(U,$J,.84,3023,0)
 ;;=3023^1^y^11^
 ;;^UTILITY(U,$J,.84,3023,1,0)
 ;;=^^1^1^2931129^^
 ;;^UTILITY(U,$J,.84,3023,1,1,0)
 ;;=The given page was not found on the form.
 ;;^UTILITY(U,$J,.84,3023,2,0)
 ;;=^^1^1^2931129^^^
 ;;^UTILITY(U,$J,.84,3023,2,1,0)
 ;;=The form does not contain a page |1|.
 ;;^UTILITY(U,$J,.84,3023,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3023,3,1,0)
 ;;=1^Page name or number
 ;;^UTILITY(U,$J,.84,3031,0)
 ;;=3031^1^y^11^
 ;;^UTILITY(U,$J,.84,3031,1,0)
 ;;=^^1^1^2931124^
 ;;^UTILITY(U,$J,.84,3031,1,1,0)
 ;;=The call to the specified ScreenMan utility failed.
 ;;^UTILITY(U,$J,.84,3031,2,0)
 ;;=^^1^1^2931124^
 ;;^UTILITY(U,$J,.84,3031,2,1,0)
 ;;=NOTE: The programmer call to the |1| ScreenMan utility failed.
 ;;^UTILITY(U,$J,.84,3031,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3031,3,1,0)
 ;;=1^ScreenMan utility entry point.
 ;;^UTILITY(U,$J,.84,3041,0)
 ;;=3041^1^y^11^
 ;;^UTILITY(U,$J,.84,3041,1,0)
 ;;=^^1^1^2931130^^
 ;;^UTILITY(U,$J,.84,3041,1,1,0)
 ;;=Errors were encountered while attempting to load the page.
 ;;^UTILITY(U,$J,.84,3041,2,0)
 ;;=^^1^1^2931130^
 ;;^UTILITY(U,$J,.84,3041,2,1,0)
 ;;=Page |1| (|2|) could not be loaded.
 ;;^UTILITY(U,$J,.84,3041,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,3041,3,1,0)
 ;;=1^Page number
 ;;^UTILITY(U,$J,.84,3041,3,2,0)
 ;;=2^Page name
 ;;^UTILITY(U,$J,.84,3051,0)
 ;;=3051^1^y^11^
 ;;^UTILITY(U,$J,.84,3051,1,0)
 ;;=^^2^2^2931129^^^^
 ;;^UTILITY(U,$J,.84,3051,1,1,0)
 ;;=The block has no 0 node in the Block file or was not found in the "B"
 ;;^UTILITY(U,$J,.84,3051,1,2,0)
 ;;=index.
 ;;^UTILITY(U,$J,.84,3051,2,0)
 ;;=^^1^1^2931129^^^
 ;;^UTILITY(U,$J,.84,3051,2,1,0)
 ;;=Block |1| does not exist in the Block file.
 ;;^UTILITY(U,$J,.84,3051,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3051,3,1,0)
 ;;=1^Block number or name
 ;;^UTILITY(U,$J,.84,3053,0)
 ;;=3053^1^y^11^
 ;;^UTILITY(U,$J,.84,3053,1,0)
 ;;=^^4^4^2931129^
 ;;^UTILITY(U,$J,.84,3053,1,1,0)
 ;;=The specified block was not found on the page.  For example, it was not
 ;;^UTILITY(U,$J,.84,3053,1,2,0)
 ;;=found in the "AC" or "B" index in the block multiple of the page multiple
 ;;^UTILITY(U,$J,.84,3053,1,3,0)
 ;;=of the Form file, or the 0 node of the block in the block multiple is
 ;;^UTILITY(U,$J,.84,3053,1,4,0)
 ;;=missing.
 ;;^UTILITY(U,$J,.84,3053,2,0)
 ;;=^^1^1^2931129^^
 ;;^UTILITY(U,$J,.84,3053,2,1,0)
 ;;=Block |1| was not found on page |2|.
 ;;^UTILITY(U,$J,.84,3053,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,3053,3,1,0)
 ;;=1^Block order, name, or number
 ;;^UTILITY(U,$J,.84,3053,3,2,0)
 ;;=2^Page number and/or name
 ;;^UTILITY(U,$J,.84,3055,0)
 ;;=3055^1^y^11^
 ;;^UTILITY(U,$J,.84,3055,1,0)
 ;;=^^1^1^2931129^^^
 ;;^UTILITY(U,$J,.84,3055,1,1,0)
 ;;=There are no blocks defined on the page.
 ;;^UTILITY(U,$J,.84,3055,2,0)
 ;;=^^1^1^2931129^^^
 ;;^UTILITY(U,$J,.84,3055,2,1,0)
 ;;=There are no blocks defined on page |1|.
 ;;^UTILITY(U,$J,.84,3055,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3055,3,1,0)
 ;;=1^Page name and/or number
 ;;^UTILITY(U,$J,.84,3071,0)
 ;;=3071^1^y^11^
 ;;^UTILITY(U,$J,.84,3071,1,0)
 ;;=^^1^1^2931129^^^
 ;;^UTILITY(U,$J,.84,3071,1,1,0)
 ;;=The specified block has no fields on it.
 ;;^UTILITY(U,$J,.84,3071,2,0)
 ;;=^^1^1^2931129^^
 ;;^UTILITY(U,$J,.84,3071,2,1,0)
 ;;=There are no fields defined on block |1|.
 ;;^UTILITY(U,$J,.84,3071,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,3071,3,1,0)
 ;;=1^Block name
 ;;^UTILITY(U,$J,.84,3072,0)
 ;;=3072^1^y^11^
 ;;^UTILITY(U,$J,.84,3072,1,0)
 ;;=^^1^1^2931129^

DINIT00F
DINIT00F ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,3072,1,1,0)
 ;;=The specified field was not found on the block.
 ;;^UTILITY(U,$J,.84,3072,2,0)
 ;;=^^1^1^2931129^
 ;;^UTILITY(U,$J,.84,3072,2,1,0)
 ;;=Field |1| was not found on block |2|.
 ;;^UTILITY(U,$J,.84,3072,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,3072,3,1,0)
 ;;=1^Field order, number, caption, or unique name
 ;;^UTILITY(U,$J,.84,3072,3,2,0)
 ;;=2^Block name
 ;;^UTILITY(U,$J,.84,3081,0)
 ;;=3081^1^^11
 ;;^UTILITY(U,$J,.84,3081,1,0)
 ;;=^^2^2^2931201^^
 ;;^UTILITY(U,$J,.84,3081,1,1,0)
 ;;=The field specified by FO(field) in the pointer link or computed expression
 ;;^UTILITY(U,$J,.84,3081,1,2,0)
 ;;=is not a form only field.
 ;;^UTILITY(U,$J,.84,3081,2,0)
 ;;=^^1^1^2931201^^
 ;;^UTILITY(U,$J,.84,3081,2,1,0)
 ;;=The specified field is not a form-only field.
 ;;^UTILITY(U,$J,.84,3082,0)
 ;;=3082^1^^11
 ;;^UTILITY(U,$J,.84,3082,1,0)
 ;;=^^3^3^2931203^
 ;;^UTILITY(U,$J,.84,3082,1,1,0)
 ;;=The field, block, and/or page is missing or invalid in the expression
 ;;^UTILITY(U,$J,.84,3082,1,2,0)
 ;;=FO(field,block,page), used in the pointer link, parent field, or computed
 ;;^UTILITY(U,$J,.84,3082,1,3,0)
 ;;=expression.
 ;;^UTILITY(U,$J,.84,3082,2,0)
 ;;=^^1^1^2931203^
 ;;^UTILITY(U,$J,.84,3082,2,1,0)
 ;;=Parameters are missing or invalid in an FO() expression.
 ;;^UTILITY(U,$J,.84,3083,0)
 ;;=3083^1^^11
 ;;^UTILITY(U,$J,.84,3083,1,0)
 ;;=^^1^1^2931203^^
 ;;^UTILITY(U,$J,.84,3083,1,1,0)
 ;;=The relational expression is incomplete.
 ;;^UTILITY(U,$J,.84,3083,2,0)
 ;;=^^1^1^2931203^^
 ;;^UTILITY(U,$J,.84,3083,2,1,0)
 ;;=The relational expression is incomplete.
 ;;^UTILITY(U,$J,.84,3084,0)
 ;;=3084^1^^11
 ;;^UTILITY(U,$J,.84,3084,1,0)
 ;;=^^3^3^2931203^^
 ;;^UTILITY(U,$J,.84,3084,1,1,0)
 ;;=In a computed expression, a form-only field should be referenced as
 ;;^UTILITY(U,$J,.84,3084,1,2,0)
 ;;={FO(field,block)} or {FO(field)}.  The page parameter should not be
 ;;^UTILITY(U,$J,.84,3084,1,3,0)
 ;;=included.
 ;;^UTILITY(U,$J,.84,3084,2,0)
 ;;=^^1^1^2931203^^
 ;;^UTILITY(U,$J,.84,3084,2,1,0)
 ;;=The FO() expression should not contain a page parameter.
 ;;^UTILITY(U,$J,.84,3085,0)
 ;;=3085^1^^11
 ;;^UTILITY(U,$J,.84,3085,1,0)
 ;;=^^3^3^2931203^
 ;;^UTILITY(U,$J,.84,3085,1,1,0)
 ;;=In a computed expression, a form-only field should be referenced as
 ;;^UTILITY(U,$J,.84,3085,1,2,0)
 ;;={FO(field,block)} or {FO(field)}.  The block parameter should be
 ;;^UTILITY(U,$J,.84,3085,1,3,0)
 ;;=either the block name or `block number.  It should not be a block order.
 ;;^UTILITY(U,$J,.84,3085,2,0)
 ;;=^^1^1^2931203^^
 ;;^UTILITY(U,$J,.84,3085,2,1,0)
 ;;=The FO() expression should not use block order to specify a block.
 ;;^UTILITY(U,$J,.84,3086,0)
 ;;=3086^1^^11
 ;;^UTILITY(U,$J,.84,3086,1,0)
 ;;=^^2^2^2940708^^
 ;;^UTILITY(U,$J,.84,3086,1,1,0)
 ;;=Reject calls to PUT^DDSVAL which attempt to set the .01 field of a file to
 ;;^UTILITY(U,$J,.84,3086,1,2,0)
 ;;="" or "@".
 ;;^UTILITY(U,$J,.84,3086,2,0)
 ;;=^^1^1^2940708^^^
 ;;^UTILITY(U,$J,.84,3086,2,1,0)
 ;;=PUT^DDSVAL cannot be used to delete an entry.
 ;;^UTILITY(U,$J,.84,3091,0)
 ;;=3091^1^^11
 ;;^UTILITY(U,$J,.84,3091,1,0)
 ;;=^^1^1^2930722^
 ;;^UTILITY(U,$J,.84,3091,1,1,0)
 ;;=The data could not be filed.
 ;;^UTILITY(U,$J,.84,3091,2,0)
 ;;=^^1^1^2931202^^
 ;;^UTILITY(U,$J,.84,3091,2,1,0)
 ;;=THE DATA COULD NOT BE FILED.
 ;;^UTILITY(U,$J,.84,3092,0)
 ;;=3092^1^y^11^
 ;;^UTILITY(U,$J,.84,3092,1,0)
 ;;=^^1^1^2940713^^^^
 ;;^UTILITY(U,$J,.84,3092,1,1,0)
 ;;=The given field is required and its current value is null.
 ;;^UTILITY(U,$J,.84,3092,2,0)
 ;;=^^1^1^2940713^^^
 ;;^UTILITY(U,$J,.84,3092,2,1,0)
 ;;=|1|, |2| is a required field |3|
 ;;^UTILITY(U,$J,.84,3092,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,3092,3,1,0)
 ;;=1^Page name
 ;;^UTILITY(U,$J,.84,3092,3,2,0)
 ;;=2^Caption
 ;;^UTILITY(U,$J,.84,3092,3,3,0)
 ;;=3^Subrecord name in parentheses
 ;;^UTILITY(U,$J,.84,7001,0)
 ;;=7001^2^^11
 ;;^UTILITY(U,$J,.84,7001,1,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,7001,1,1,0)
 ;;=This is the general Yes/No Prompt
 ;;^UTILITY(U,$J,.84,7001,2,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,7001,2,1,0)
 ;;=Yes^No
 ;;^UTILITY(U,$J,.84,7001,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,7002,0)
 ;;=7002^2^^11
 ;;^UTILITY(U,$J,.84,7002,1,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,7002,1,1,0)
 ;;=Insert/Replace Switch
 ;;^UTILITY(U,$J,.84,7002,2,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,7002,2,1,0)
 ;;=Insert ^Replace

DINIT00G
DINIT00G ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,7002,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,7003,0)
 ;;=7003^2^^11
 ;;^UTILITY(U,$J,.84,7003,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,7003,1,1,0)
 ;;=Yes/No prompt for Reader
 ;;^UTILITY(U,$J,.84,7003,2,0)
 ;;=^^1^1^2940414^^
 ;;^UTILITY(U,$J,.84,7003,2,1,0)
 ;;=y:YES;n:NO
 ;;^UTILITY(U,$J,.84,7003,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,7004,0)
 ;;=7004^2^^11
 ;;^UTILITY(U,$J,.84,7004,1,0)
 ;;=^^2^2^2940909^^^^
 ;;^UTILITY(U,$J,.84,7004,1,1,0)
 ;;=Set of codes for reader call when asking user whether they want to include
 ;;^UTILITY(U,$J,.84,7004,1,2,0)
 ;;=computed fields and/or IEN in CAPTIONED output.
 ;;^UTILITY(U,$J,.84,7004,2,0)
 ;;=^^4^4^2940914^^
 ;;^UTILITY(U,$J,.84,7004,2,1,0)
 ;;=N:NO - No record number (IEN), no Computed Fields;
 ;;^UTILITY(U,$J,.84,7004,2,2,0)
 ;;=Y:Computed Fields;
 ;;^UTILITY(U,$J,.84,7004,2,3,0)
 ;;=R:Record Number (IEN);
 ;;^UTILITY(U,$J,.84,7004,2,4,0)
 ;;=B:BOTH Computed Fields and Record Number (IEN)
 ;;^UTILITY(U,$J,.84,8001,0)
 ;;=8001^2^^11
 ;;^UTILITY(U,$J,.84,8001,1,0)
 ;;=^^1^1^2941118^^^^
 ;;^UTILITY(U,$J,.84,8001,1,1,0)
 ;;=Prompt for name of compiled template or cross-reference routine.
 ;;^UTILITY(U,$J,.84,8001,2,0)
 ;;=^^1^1^2941118^^
 ;;^UTILITY(U,$J,.84,8001,2,1,0)
 ;;=Routine Name
 ;;^UTILITY(U,$J,.84,8001,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8001,5,0)
 ;;=^.841^3^3
 ;;^UTILITY(U,$J,.84,8001,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8001,5,2,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8001,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8002,0)
 ;;=8002^2^^11
 ;;^UTILITY(U,$J,.84,8002,1,0)
 ;;=^^1^1^2940426^^^^
 ;;^UTILITY(U,$J,.84,8002,1,1,0)
 ;;=Prompt for including computed fields and/or IEN in CAPTIONED output.
 ;;^UTILITY(U,$J,.84,8002,2,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,8002,2,1,0)
 ;;=Include COMPUTED fields
 ;;^UTILITY(U,$J,.84,8002,4,0)
 ;;=^.847P
 ;;^UTILITY(U,$J,.84,8003,0)
 ;;=8003^2^y^11^
 ;;^UTILITY(U,$J,.84,8003,1,0)
 ;;=^^2^2^2931101^^^^
 ;;^UTILITY(U,$J,.84,8003,1,1,0)
 ;;=Used in Print to display sort criteria in heading--when BY(0) contains
 ;;^UTILITY(U,$J,.84,8003,1,2,0)
 ;;=a search template name.
 ;;^UTILITY(U,$J,.84,8003,2,0)
 ;;=^^1^1^2931102^
 ;;^UTILITY(U,$J,.84,8003,2,1,0)
 ;;=Records from list on |1| search template
 ;;^UTILITY(U,$J,.84,8003,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8003,3,1,0)
 ;;=1^Name of search template.
 ;;^UTILITY(U,$J,.84,8003,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8003,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8003,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8004,0)
 ;;=8004^2^y^11^
 ;;^UTILITY(U,$J,.84,8004,1,0)
 ;;=^^3^3^2931101^
 ;;^UTILITY(U,$J,.84,8004,1,1,0)
 ;;=Used in Print to display sort criteria in heading--when BY(0) contains
 ;;^UTILITY(U,$J,.84,8004,1,2,0)
 ;;=the global reference for a cross-reference or for another global
 ;;^UTILITY(U,$J,.84,8004,1,3,0)
 ;;=containing a list of record numbers.
 ;;^UTILITY(U,$J,.84,8004,2,0)
 ;;=^^1^1^2931101^^
 ;;^UTILITY(U,$J,.84,8004,2,1,0)
 ;;=Sort using |1|
 ;;^UTILITY(U,$J,.84,8004,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8004,3,1,0)
 ;;=1^Global reference passed in BY(0)
 ;;^UTILITY(U,$J,.84,8004,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8004,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8004,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8005,0)
 ;;=8005^2^y^11^
 ;;^UTILITY(U,$J,.84,8005,1,0)
 ;;=^^4^4^2940908^^
 ;;^UTILITY(U,$J,.84,8005,1,1,0)
 ;;=At the heading prompt during the FileMan print, the user can enter flags
 ;;^UTILITY(U,$J,.84,8005,1,2,0)
 ;;=to either suppress printing of the header if there are no records to
 ;;^UTILITY(U,$J,.84,8005,1,3,0)
 ;;=print, or to cause the search/sort criteria to print in the header.  This
 ;;^UTILITY(U,$J,.84,8005,1,4,0)
 ;;=is the help prompt.
 ;;^UTILITY(U,$J,.84,8005,2,0)
 ;;=^^11^11^2940908^^^^
 ;;^UTILITY(U,$J,.84,8005,2,1,0)
 ;;=There are two different options:
 ;;^UTILITY(U,$J,.84,8005,2,2,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8005,2,3,0)
 ;;=1) Accept the default heading or enter a custom heading.
 ;;^UTILITY(U,$J,.84,8005,2,4,0)
 ;;= For no heading at all, type @.
 ;;^UTILITY(U,$J,.84,8005,2,5,0)
 ;;= To use a Print Template for the heading, type [TEMPLATE NAME].
 ;;^UTILITY(U,$J,.84,8005,2,6,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8005,2,7,0)
 ;;=2) Replace the default heading with:
 ;;^UTILITY(U,$J,.84,8005,2,8,0)
 ;;= S  to Suppress the |1|, and/or
 ;;^UTILITY(U,$J,.84,8005,2,9,0)
 ;;= C  to print |2| Criteria in the heading.

DINIT00H
DINIT00H ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8005,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8005,2,11,0)
 ;;=If S and/or C is entered, the heading prompt will re-appear.
 ;;^UTILITY(U,$J,.84,8005,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,8005,3,1,0)
 ;;=1^Text from either entry #8006 or #8007, depending on whether we're coming from the search or print.
 ;;^UTILITY(U,$J,.84,8005,3,2,0)
 ;;=2^Text from either entry #8038 or #8037, depending on whether we're coming from the search or print.
 ;;^UTILITY(U,$J,.84,8005,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8005,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8005,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8006,0)
 ;;=8006^2^^11^
 ;;^UTILITY(U,$J,.84,8006,1,0)
 ;;=^^1^1^2940526^^^^
 ;;^UTILITY(U,$J,.84,8006,1,1,0)
 ;;=Inserted as a parameter to #8005 when called from the SEARCH Option.
 ;;^UTILITY(U,$J,.84,8006,2,0)
 ;;=^^1^1^2940526^^
 ;;^UTILITY(U,$J,.84,8006,2,1,0)
 ;;=Number of Matches from the search
 ;;^UTILITY(U,$J,.84,8006,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8006,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8006,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8007,0)
 ;;=8007^2^^11^
 ;;^UTILITY(U,$J,.84,8007,1,0)
 ;;=^^1^1^2940526^^^^
 ;;^UTILITY(U,$J,.84,8007,1,1,0)
 ;;=Inserted as a parameter to #8005 when called from the PRINT Option.
 ;;^UTILITY(U,$J,.84,8007,2,0)
 ;;=^^1^1^2940526^
 ;;^UTILITY(U,$J,.84,8007,2,1,0)
 ;;=heading when there are no records to print
 ;;^UTILITY(U,$J,.84,8007,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8007,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8007,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8008,0)
 ;;=8008^2^^11^
 ;;^UTILITY(U,$J,.84,8008,1,0)
 ;;=^^4^4^2940908^
 ;;^UTILITY(U,$J,.84,8008,1,1,0)
 ;;=At the HEADING prompt during the FileMan print, the user can enter flags
 ;;^UTILITY(U,$J,.84,8008,1,2,0)
 ;;=to either suppress printing of the header if there are no records to
 ;;^UTILITY(U,$J,.84,8008,1,3,0)
 ;;=print, or to cause the sort criteria to print in the header.  This is the
 ;;^UTILITY(U,$J,.84,8008,1,4,0)
 ;;=prompt for the reader call.
 ;;^UTILITY(U,$J,.84,8008,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,8008,2,1,0)
 ;;=Heading (S/C)
 ;;^UTILITY(U,$J,.84,8008,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8008,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8008,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8009,0)
 ;;=8009^2^^11^
 ;;^UTILITY(U,$J,.84,8009,1,0)
 ;;=^^2^2^2940908^^^^
 ;;^UTILITY(U,$J,.84,8009,1,1,0)
 ;;=This is the normal help message given if user enters a question mark when
 ;;^UTILITY(U,$J,.84,8009,1,2,0)
 ;;=being prompted for the HEADER during a FileMan print.
 ;;^UTILITY(U,$J,.84,8009,2,0)
 ;;=^^3^3^2940908^
 ;;^UTILITY(U,$J,.84,8009,2,1,0)
 ;;=Accept default heading or enter a custom heading.
 ;;^UTILITY(U,$J,.84,8009,2,2,0)
 ;;=For no heading at all, type @.
 ;;^UTILITY(U,$J,.84,8009,2,3,0)
 ;;=To use a Print Template for the heading, type [TEMPLATE NAME].
 ;;^UTILITY(U,$J,.84,8009,3,0)
 ;;=^.845
 ;;^UTILITY(U,$J,.84,8009,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8009,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8009,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8010,0)
 ;;=8010^2^y^11^
 ;;^UTILITY(U,$J,.84,8010,1,0)
 ;;=^^1^1^2931102^^^^
 ;;^UTILITY(U,$J,.84,8010,1,1,0)
 ;;=Print dialog coming from routine ^DIP31.
 ;;^UTILITY(U,$J,.84,8010,2,0)
 ;;=^^1^1^2931102^
 ;;^UTILITY(U,$J,.84,8010,2,1,0)
 ;;=** Suppress the |1|.
 ;;^UTILITY(U,$J,.84,8010,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8010,3,1,0)
 ;;=1^Text from either entry #8006 or #8007, depending on whether it's called from the SEARCH or PRINT Options.
 ;;^UTILITY(U,$J,.84,8010,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8010,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8010,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8011,0)
 ;;=8011^2^y^11^
 ;;^UTILITY(U,$J,.84,8011,1,0)
 ;;=^^1^1^2940526^^^^
 ;;^UTILITY(U,$J,.84,8011,1,1,0)
 ;;=Dialog coming from routine ^DIP31
 ;;^UTILITY(U,$J,.84,8011,2,0)
 ;;=^^1^1^2940526^
 ;;^UTILITY(U,$J,.84,8011,2,1,0)
 ;;=** print |1| Criteria in heading.
 ;;^UTILITY(U,$J,.84,8011,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8011,3,1,0)
 ;;=1^The word SORT or SEARCH, depending on which option we're coming from.
 ;;^UTILITY(U,$J,.84,8011,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8011,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8011,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8012,0)
 ;;=8012^2^^11^
 ;;^UTILITY(U,$J,.84,8012,1,0)
 ;;=^^2^2^2931102^^^
 ;;^UTILITY(U,$J,.84,8012,1,1,0)
 ;;=The word HEADING to be used in the prompt for the heading from the FileMan

DINIT00I
DINIT00I ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8012,1,2,0)
 ;;=PRINT option.
 ;;^UTILITY(U,$J,.84,8012,2,0)
 ;;=^^1^1^2931102^
 ;;^UTILITY(U,$J,.84,8012,2,1,0)
 ;;=Heading
 ;;^UTILITY(U,$J,.84,8012,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8012,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8012,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8013,0)
 ;;=8013^2^^11^
 ;;^UTILITY(U,$J,.84,8013,1,0)
 ;;=^^3^3^2931105^^
 ;;^UTILITY(U,$J,.84,8013,1,1,0)
 ;;=The DD for the file of files is not completely FileMan compatible.  This
 ;;^UTILITY(U,$J,.84,8013,1,2,0)
 ;;=is the field name prompt for the POST-SELECTION ACTION field on the file
 ;;^UTILITY(U,$J,.84,8013,1,3,0)
 ;;=of files.  Prompt appears when file attributes.
 ;;^UTILITY(U,$J,.84,8013,2,0)
 ;;=^^1^1^2931105^^
 ;;^UTILITY(U,$J,.84,8013,2,1,0)
 ;;=POST-SELECTION ACTION
 ;;^UTILITY(U,$J,.84,8013,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8013,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8014,0)
 ;;=8014^2^^11^
 ;;^UTILITY(U,$J,.84,8014,1,0)
 ;;=^^3^3^2931105^
 ;;^UTILITY(U,$J,.84,8014,1,1,0)
 ;;=The DD for the file of files is not completely FileMan compatible.  This
 ;;^UTILITY(U,$J,.84,8014,1,2,0)
 ;;=is the field name prompt for the LOOK-UP PROGRAM field on the file
 ;;^UTILITY(U,$J,.84,8014,1,3,0)
 ;;=of files.  Prompt appears when file attributes are edited.
 ;;^UTILITY(U,$J,.84,8014,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8014,2,1,0)
 ;;=LOOK-UP PROGRAM
 ;;^UTILITY(U,$J,.84,8014,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8014,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8015,0)
 ;;=8015^2^^11
 ;;^UTILITY(U,$J,.84,8015,1,0)
 ;;=^^2^2^2931105^
 ;;^UTILITY(U,$J,.84,8015,1,1,0)
 ;;=Standard prompt to verify to the user that they just deleted something
 ;;^UTILITY(U,$J,.84,8015,1,2,0)
 ;;=with the "@".
 ;;^UTILITY(U,$J,.84,8015,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8015,2,1,0)
 ;;=Deleted.
 ;;^UTILITY(U,$J,.84,8015,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8015,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8016,0)
 ;;=8016^2^y^11^
 ;;^UTILITY(U,$J,.84,8016,1,0)
 ;;=^^2^2^2931105^^^^
 ;;^UTILITY(U,$J,.84,8016,1,1,0)
 ;;=Called after performing routine existence test to tell user that routine
 ;;^UTILITY(U,$J,.84,8016,1,2,0)
 ;;=is already in their directory.
 ;;^UTILITY(U,$J,.84,8016,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8016,2,1,0)
 ;;=Note that |1| is already in the routine directory.
 ;;^UTILITY(U,$J,.84,8016,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8016,3,1,0)
 ;;=1^Name of the routine.
 ;;^UTILITY(U,$J,.84,8016,5,0)
 ;;=^.841^4^4
 ;;^UTILITY(U,$J,.84,8016,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8016,5,2,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8016,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8016,5,4,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8017,0)
 ;;=8017^2^^11
 ;;^UTILITY(U,$J,.84,8017,1,0)
 ;;=^^2^2^2931105^
 ;;^UTILITY(U,$J,.84,8017,1,1,0)
 ;;=Message warning user that a routine does not exist in their routine
 ;;^UTILITY(U,$J,.84,8017,1,2,0)
 ;;=directory.
 ;;^UTILITY(U,$J,.84,8017,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8017,2,1,0)
 ;;=This routine does not exist in the routine directory.
 ;;^UTILITY(U,$J,.84,8017,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8017,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8018,0)
 ;;=8018^2^y^11^
 ;;^UTILITY(U,$J,.84,8018,1,0)
 ;;=^^2^2^2931105^
 ;;^UTILITY(U,$J,.84,8018,1,1,0)
 ;;=Prompt showing the user a routine name previously used for compiled
 ;;^UTILITY(U,$J,.84,8018,1,2,0)
 ;;=routines (input templates, print templates, cross-references).
 ;;^UTILITY(U,$J,.84,8018,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8018,2,1,0)
 ;;=Previously compiled under routine name |1|.
 ;;^UTILITY(U,$J,.84,8018,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8018,3,1,0)
 ;;=1^Routine name from "DIKOLD" or "ROUOLD" nodes in templates or DD for cross-references.
 ;;^UTILITY(U,$J,.84,8018,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8018,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8019,0)
 ;;=8019^2^^11
 ;;^UTILITY(U,$J,.84,8019,1,0)
 ;;=^^3^3^2931105^^
 ;;^UTILITY(U,$J,.84,8019,1,1,0)
 ;;=The DD for the file of files is not completely FileMan compatible.  This
 ;;^UTILITY(U,$J,.84,8019,1,2,0)
 ;;=is the field name prompt for the CROSS-REFERENCE ROUTINE field on the file
 ;;^UTILITY(U,$J,.84,8019,1,3,0)
 ;;=of files.  Prompt appears when file attributes are edited.
 ;;^UTILITY(U,$J,.84,8019,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,8019,2,1,0)
 ;;=CROSS-REFERENCE ROUTINE
 ;;^UTILITY(U,$J,.84,8019,5,0)
 ;;=^.841^1^1

DINIT00J
DINIT00J ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8019,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8020,0)
 ;;=8020^2^^11
 ;;^UTILITY(U,$J,.84,8020,1,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,8020,1,1,0)
 ;;=This prompt asks the user whether they are ready to compile, when
 ;;^UTILITY(U,$J,.84,8020,1,2,0)
 ;;=compiling TEMPLATES or CROSS-REFERENCES.
 ;;^UTILITY(U,$J,.84,8020,2,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,8020,2,1,0)
 ;;=Should the compilation run now
 ;;^UTILITY(U,$J,.84,8020,5,0)
 ;;=^.841^4^4
 ;;^UTILITY(U,$J,.84,8020,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8020,5,2,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8020,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8020,5,4,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8021,0)
 ;;=8021^2^^11
 ;;^UTILITY(U,$J,.84,8021,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,8021,1,1,0)
 ;;=Message from editing the CROSS-REFERENCE ROUTINE.  If this field is
 ;;^UTILITY(U,$J,.84,8021,1,2,0)
 ;;=deleted, the message notifies the user that the compiled routines will no
 ;;^UTILITY(U,$J,.84,8021,1,3,0)
 ;;=longer be used for re-indexing.
 ;;^UTILITY(U,$J,.84,8021,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,8021,2,1,0)
 ;;=The compiled routines will no longer be used for re-indexing.
 ;;^UTILITY(U,$J,.84,8021,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8021,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,8022,0)
 ;;=8022^2^^11
 ;;^UTILITY(U,$J,.84,8022,1,0)
 ;;=^^2^2^2931110^^^
 ;;^UTILITY(U,$J,.84,8022,1,1,0)
 ;;=Used when compiling PRINT templates, this is the prompt for the margin
 ;;^UTILITY(U,$J,.84,8022,1,2,0)
 ;;=width to be used for the printed report.
 ;;^UTILITY(U,$J,.84,8022,2,0)
 ;;=^^1^1^2931112^
 ;;^UTILITY(U,$J,.84,8022,2,1,0)
 ;;=Margin Width for output
 ;;^UTILITY(U,$J,.84,8022,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8022,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8023,0)
 ;;=8023^2^^11
 ;;^UTILITY(U,$J,.84,8023,1,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,8023,1,1,0)
 ;;=This is the help prompt for MARGIN WIDTH FOR OUTPUT, used when compiling
 ;;^UTILITY(U,$J,.84,8023,1,2,0)
 ;;=PRINT templates.
 ;;^UTILITY(U,$J,.84,8023,2,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,8023,2,1,0)
 ;;=Type a number from 19 to 255.  This is the number of columns
 ;;^UTILITY(U,$J,.84,8023,2,2,0)
 ;;=on the report
 ;;^UTILITY(U,$J,.84,8023,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8023,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8024,0)
 ;;=8024^2^y^11^
 ;;^UTILITY(U,$J,.84,8024,1,0)
 ;;=^^1^1^2931110^^^^
 ;;^UTILITY(U,$J,.84,8024,1,1,0)
 ;;=This is the text that tells the user they are now compiling routines.
 ;;^UTILITY(U,$J,.84,8024,2,0)
 ;;=^^1^1^2931110^^^^
 ;;^UTILITY(U,$J,.84,8024,2,1,0)
 ;;=Compiling |1| |2| of File |3|.
 ;;^UTILITY(U,$J,.84,8024,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,8024,3,1,0)
 ;;=1^Name of template, if compiling templates.
 ;;^UTILITY(U,$J,.84,8024,3,2,0)
 ;;=2^The words "print template", "cross-references", etc. (i.e., what is being compiled).
 ;;^UTILITY(U,$J,.84,8024,3,3,0)
 ;;=3^File name
 ;;^UTILITY(U,$J,.84,8024,5,0)
 ;;=^.841^6^6
 ;;^UTILITY(U,$J,.84,8024,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8024,5,2,0)
 ;;=DIPZ^EN
 ;;^UTILITY(U,$J,.84,8024,5,3,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8024,5,4,0)
 ;;=DIEZ^EN
 ;;^UTILITY(U,$J,.84,8024,5,5,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8024,5,6,0)
 ;;=DIKZ^EN
 ;;^UTILITY(U,$J,.84,8025,0)
 ;;=8025^2^y^11^
 ;;^UTILITY(U,$J,.84,8025,1,0)
 ;;=^^2^2^2931110^^
 ;;^UTILITY(U,$J,.84,8025,1,1,0)
 ;;=Notify user that a routine has been filed.  Used during compilation of
 ;;^UTILITY(U,$J,.84,8025,1,2,0)
 ;;=TEMPLATES and CROSS-REFERENCES.
 ;;^UTILITY(U,$J,.84,8025,2,0)
 ;;=^^1^1^2931110^^^
 ;;^UTILITY(U,$J,.84,8025,2,1,0)
 ;;='|1|' ROUTINE FILED.
 ;;^UTILITY(U,$J,.84,8025,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8025,3,1,0)
 ;;=1^Routine name
 ;;^UTILITY(U,$J,.84,8025,5,0)
 ;;=^.841^8^7
 ;;^UTILITY(U,$J,.84,8025,5,1,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8025,5,2,0)
 ;;=DIKZ^EN
 ;;^UTILITY(U,$J,.84,8025,5,3,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,8025,5,5,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8025,5,6,0)
 ;;=DIPZ^EN
 ;;^UTILITY(U,$J,.84,8025,5,7,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8025,5,8,0)
 ;;=DIEZ^EN
 ;;^UTILITY(U,$J,.84,8026,0)
 ;;=8026^2^y^11^
 ;;^UTILITY(U,$J,.84,8026,1,0)
 ;;=^^2^2^2931110^^^
 ;;^UTILITY(U,$J,.84,8026,1,1,0)
 ;;=Used to notify the user that templates or cross-references have been
 ;;^UTILITY(U,$J,.84,8026,1,2,0)
 ;;=UNCOMPILED.
 ;;^UTILITY(U,$J,.84,8026,2,0)
 ;;=^^1^1^2931110^

DINIT00K
DINIT00K ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8026,2,1,0)
 ;;=|1| now uncompiled.
 ;;^UTILITY(U,$J,.84,8026,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8026,3,1,0)
 ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES'
 ;;^UTILITY(U,$J,.84,8026,5,0)
 ;;=^.841^6^6
 ;;^UTILITY(U,$J,.84,8026,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8026,5,2,0)
 ;;=DIPZ^EN
 ;;^UTILITY(U,$J,.84,8026,5,3,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8026,5,4,0)
 ;;=DIEZ^EN
 ;;^UTILITY(U,$J,.84,8026,5,5,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8026,5,6,0)
 ;;=DIKZ^EN
 ;;^UTILITY(U,$J,.84,8027,0)
 ;;=8027^2^^11
 ;;^UTILITY(U,$J,.84,8027,1,0)
 ;;=^^2^2^2931110^^^
 ;;^UTILITY(U,$J,.84,8027,1,1,0)
 ;;=Prompt for maximum routine size, used when compiling templates or
 ;;^UTILITY(U,$J,.84,8027,1,2,0)
 ;;=cross-references.
 ;;^UTILITY(U,$J,.84,8027,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8027,2,1,0)
 ;;=Maximum routine size on this computer (in bytes).
 ;;^UTILITY(U,$J,.84,8027,5,0)
 ;;=^.841^3^3
 ;;^UTILITY(U,$J,.84,8027,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8027,5,2,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8027,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8028,0)
 ;;=8028^2^y^11^
 ;;^UTILITY(U,$J,.84,8028,1,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,8028,1,1,0)
 ;;=Extended dialogue for asking user whether they wish to UNCOMPILE
 ;;^UTILITY(U,$J,.84,8028,1,2,0)
 ;;=a previously compiled template or cross-references.
 ;;^UTILITY(U,$J,.84,8028,2,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,8028,2,1,0)
 ;;= |1| currently compiled under namespace |2|.
 ;;^UTILITY(U,$J,.84,8028,2,2,0)
 ;;=UNCOMPILE the |1|
 ;;^UTILITY(U,$J,.84,8028,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,8028,3,1,0)
 ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES'
 ;;^UTILITY(U,$J,.84,8028,3,2,0)
 ;;=2^Routine name under which templates were previously compiled.
 ;;^UTILITY(U,$J,.84,8028,5,0)
 ;;=^.841^4^4
 ;;^UTILITY(U,$J,.84,8028,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8028,5,2,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8028,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8028,5,4,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,8029,0)
 ;;=8029^2^y^11^
 ;;^UTILITY(U,$J,.84,8029,1,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,8029,1,1,0)
 ;;=Extended dialogue for asking user whether they wish to COMPILE a
 ;;^UTILITY(U,$J,.84,8029,1,2,0)
 ;;=template or cross-references.
 ;;^UTILITY(U,$J,.84,8029,2,0)
 ;;=^^2^2^2931110^
 ;;^UTILITY(U,$J,.84,8029,2,1,0)
 ;;= |1| not currently compiled.
 ;;^UTILITY(U,$J,.84,8029,2,2,0)
 ;;=COMPILE the |1|
 ;;^UTILITY(U,$J,.84,8029,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8029,3,1,0)
 ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES'
 ;;^UTILITY(U,$J,.84,8029,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8029,5,1,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,8030,0)
 ;;=8030^2^y^11^
 ;;^UTILITY(U,$J,.84,8030,1,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,8030,1,1,0)
 ;;=Warning to user that SORT/PRINT templates are uneditable because the PRINT
 ;;^UTILITY(U,$J,.84,8030,1,2,0)
 ;;=TEMPLATE field on the SORT TEMPLATE has linked it with a print template.
 ;;^UTILITY(U,$J,.84,8030,2,0)
 ;;=^^7^7^2931112^
 ;;^UTILITY(U,$J,.84,8030,2,1,0)
 ;;=Because this Sort Template has been linked with the Print Template
 ;;^UTILITY(U,$J,.84,8030,2,2,0)
 ;;=|1|, neither template can be edited from this option.
 ;;^UTILITY(U,$J,.84,8030,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8030,2,4,0)
 ;;=To edit the templates, first use the FileMan TEMPLATE EDIT
 ;;^UTILITY(U,$J,.84,8030,2,5,0)
 ;;=option to edit the Sort Template, and delete the field called
 ;;^UTILITY(U,$J,.84,8030,2,6,0)
 ;;='PRINT TEMPLATE'.  Then, the templates can be edited from
 ;;^UTILITY(U,$J,.84,8030,2,7,0)
 ;;=the PRINT option.
 ;;^UTILITY(U,$J,.84,8030,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8030,3,1,0)
 ;;=1^Name of associated PRINT TEMPLATE.
 ;;^UTILITY(U,$J,.84,8030,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8030,5,1,0)
 ;;=DIP^EN
 ;;^UTILITY(U,$J,.84,8031,0)
 ;;=8031^2^^11
 ;;^UTILITY(U,$J,.84,8031,1,0)
 ;;=^^1^1^2931110^^
 ;;^UTILITY(U,$J,.84,8031,1,1,0)
 ;;=Warning that compiled routine names may get too long.
 ;;^UTILITY(U,$J,.84,8031,2,0)
 ;;=^^3^3^2931110^
 ;;^UTILITY(U,$J,.84,8031,2,1,0)
 ;;=WARNING!!  Since the namespace for this routine is so long, use the
 ;;^UTILITY(U,$J,.84,8031,2,2,0)
 ;;=largest possible size to compile these routines.  Otherwise, FileMan may
 ;;^UTILITY(U,$J,.84,8031,2,3,0)
 ;;=run out of routine names.
 ;;^UTILITY(U,$J,.84,8031,5,0)
 ;;=^.841^3^3

DINIT00L
DINIT00L ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8031,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8031,5,2,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8031,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8032,0)
 ;;=8032^2^^11
 ;;^UTILITY(U,$J,.84,8032,1,0)
 ;;=^^1^1^2930702^
 ;;^UTILITY(U,$J,.84,8032,1,1,0)
 ;;=Words SEARCH TEMPLATE
 ;;^UTILITY(U,$J,.84,8032,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8032,2,1,0)
 ;;=Search Template
 ;;^UTILITY(U,$J,.84,8032,5,0)
 ;;=^.841^^0
 ;;^UTILITY(U,$J,.84,8033,0)
 ;;=8033^2^^11
 ;;^UTILITY(U,$J,.84,8033,1,0)
 ;;=^^1^1^2930701^^
 ;;^UTILITY(U,$J,.84,8033,1,1,0)
 ;;=the words INPUT TEMPLATE to use in any FileMan dialog.
 ;;^UTILITY(U,$J,.84,8033,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8033,2,1,0)
 ;;=Input Template
 ;;^UTILITY(U,$J,.84,8033,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8033,5,1,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,8033,5,2,0)
 ;;=DIEZ^EN
 ;;^UTILITY(U,$J,.84,8034,0)
 ;;=8034^2^^11
 ;;^UTILITY(U,$J,.84,8034,1,0)
 ;;=^^1^1^2930701^^
 ;;^UTILITY(U,$J,.84,8034,1,1,0)
 ;;=The words PRINT TEMPLATE to use in any FileMan dialog.
 ;;^UTILITY(U,$J,.84,8034,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8034,2,1,0)
 ;;=Print Template
 ;;^UTILITY(U,$J,.84,8034,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8034,5,1,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,8034,5,2,0)
 ;;=DIPZ^EN
 ;;^UTILITY(U,$J,.84,8035,0)
 ;;=8035^2^^11
 ;;^UTILITY(U,$J,.84,8035,1,0)
 ;;=^^1^1^2930701^
 ;;^UTILITY(U,$J,.84,8035,1,1,0)
 ;;=The words SORT TEMPLATE to use in any FileMan dialog.
 ;;^UTILITY(U,$J,.84,8035,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8035,2,1,0)
 ;;=Sort Template
 ;;^UTILITY(U,$J,.84,8035,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8035,5,1,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,8036,0)
 ;;=8036^2^^11
 ;;^UTILITY(U,$J,.84,8036,1,0)
 ;;=^^1^1^2930702^^
 ;;^UTILITY(U,$J,.84,8036,1,1,0)
 ;;=The words CROSS-REFERENCE(S) to use in any FileMan Dialog.
 ;;^UTILITY(U,$J,.84,8036,2,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8036,2,1,0)
 ;;=Cross-Reference(s)
 ;;^UTILITY(U,$J,.84,8036,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8036,5,1,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,8036,5,2,0)
 ;;=DIKZ^EN
 ;;^UTILITY(U,$J,.84,8037,0)
 ;;=8037^2^^11
 ;;^UTILITY(U,$J,.84,8037,1,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8037,1,1,0)
 ;;=The word SORT to use in any FileMan dialog.
 ;;^UTILITY(U,$J,.84,8037,2,0)
 ;;=^^1^1^2940526^
 ;;^UTILITY(U,$J,.84,8037,2,1,0)
 ;;=sort
 ;;^UTILITY(U,$J,.84,8037,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8037,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8038,0)
 ;;=8038^2^^11
 ;;^UTILITY(U,$J,.84,8038,1,0)
 ;;=^^1^1^2931110^
 ;;^UTILITY(U,$J,.84,8038,1,1,0)
 ;;=The word SEARCH to use in any FileMan dialog.
 ;;^UTILITY(U,$J,.84,8038,2,0)
 ;;=^^1^1^2940526^
 ;;^UTILITY(U,$J,.84,8038,2,1,0)
 ;;=search
 ;;^UTILITY(U,$J,.84,8038,5,0)
 ;;=^.841^2^2
 ;;^UTILITY(U,$J,.84,8038,5,1,0)
 ;;=DIP^EN1
 ;;^UTILITY(U,$J,.84,8038,5,2,0)
 ;;=DIS^ENS
 ;;^UTILITY(U,$J,.84,8040,0)
 ;;=8040^2^^11
 ;;^UTILITY(U,$J,.84,8040,1,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,8040,1,1,0)
 ;;=Advice for the Yes/No question
 ;;^UTILITY(U,$J,.84,8040,2,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,8040,2,1,0)
 ;;=Answer with 'Yes' or 'No'
 ;;^UTILITY(U,$J,.84,8040,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8041,0)
 ;;=8041^2^^11
 ;;^UTILITY(U,$J,.84,8041,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8041,2,1,0)
 ;;=This is a required response. Enter '^' to exit
 ;;^UTILITY(U,$J,.84,8041,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8042,0)
 ;;=8042^2^y^11^
 ;;^UTILITY(U,$J,.84,8042,1,0)
 ;;=^^2^2^2940315^^^^
 ;;^UTILITY(U,$J,.84,8042,1,1,0)
 ;;=This 'Select' prompt may be used for dialogs with filenames.
 ;;^UTILITY(U,$J,.84,8042,1,2,0)
 ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!!
 ;;^UTILITY(U,$J,.84,8042,2,0)
 ;;=1
 ;;^UTILITY(U,$J,.84,8042,2,1,0)
 ;;=Select |1|: 
 ;;^UTILITY(U,$J,.84,8042,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8042,3,1,0)
 ;;=1^Name of the file
 ;;^UTILITY(U,$J,.84,8042,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8043,0)
 ;;=8043^2^^11
 ;;^UTILITY(U,$J,.84,8043,1,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8043,1,1,0)
 ;;=Used for date time input to the reader.
 ;;^UTILITY(U,$J,.84,8043,2,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8043,2,1,0)
 ;;= and time
 ;;^UTILITY(U,$J,.84,8043,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8044,0)
 ;;=8044^2^^11
 ;;^UTILITY(U,$J,.84,8044,1,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8044,1,1,0)
 ;;=Used for time input to the reader.

DINIT00M
DINIT00M ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8044,2,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8044,2,1,0)
 ;;= and optional time
 ;;^UTILITY(U,$J,.84,8044,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8045,0)
 ;;=8045^2^y^11^
 ;;^UTILITY(U,$J,.84,8045,1,0)
 ;;=^^3^3^2940310^^^^
 ;;^UTILITY(U,$J,.84,8045,1,1,0)
 ;;=This prompt is used by the reader when he is building prompts for
 ;;^UTILITY(U,$J,.84,8045,1,2,0)
 ;;=Set-of-codes type data.
 ;;^UTILITY(U,$J,.84,8045,1,3,0)
 ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!!
 ;;^UTILITY(U,$J,.84,8045,2,0)
 ;;=^^1^1^2940310^^^
 ;;^UTILITY(U,$J,.84,8045,2,1,0)
 ;;=Enter |1|: 
 ;;^UTILITY(U,$J,.84,8045,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8045,3,1,0)
 ;;=1^Default Prompt from DIR("A")
 ;;^UTILITY(U,$J,.84,8045,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8046,0)
 ;;=8046^2^^11
 ;;^UTILITY(U,$J,.84,8046,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8046,1,1,0)
 ;;=Reader prompt for choices from a list
 ;;^UTILITY(U,$J,.84,8046,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8046,2,1,0)
 ;;=Select one of the following: 
 ;;^UTILITY(U,$J,.84,8046,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8047,0)
 ;;=8047^2^^11
 ;;^UTILITY(U,$J,.84,8047,1,0)
 ;;=^^1^1^2940315^^^^
 ;;^UTILITY(U,$J,.84,8047,1,1,0)
 ;;=Part one of the Replace with prompt (including spaces).
 ;;^UTILITY(U,$J,.84,8047,2,0)
 ;;=^^1^1^2940315^^^^
 ;;^UTILITY(U,$J,.84,8047,2,1,0)
 ;;=  Replace 
 ;;^UTILITY(U,$J,.84,8047,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8048,0)
 ;;=8048^2^^11
 ;;^UTILITY(U,$J,.84,8048,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8048,1,1,0)
 ;;=Part two of the Replace With editor (including spaces).
 ;;^UTILITY(U,$J,.84,8048,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8048,2,1,0)
 ;;= With 
 ;;^UTILITY(U,$J,.84,8048,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8051,0)
 ;;=8051^2^^11
 ;;^UTILITY(U,$J,.84,8051,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8051,1,1,0)
 ;;=Reader prompt
 ;;^UTILITY(U,$J,.84,8051,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8051,2,1,0)
 ;;=Enter response: 
 ;;^UTILITY(U,$J,.84,8051,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8052,0)
 ;;=8052^2^^11
 ;;^UTILITY(U,$J,.84,8052,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8052,1,1,0)
 ;;=Prompt for the reader
 ;;^UTILITY(U,$J,.84,8052,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8052,2,1,0)
 ;;=Enter Yes or No: 
 ;;^UTILITY(U,$J,.84,8052,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8053,0)
 ;;=8053^2^^11
 ;;^UTILITY(U,$J,.84,8053,1,0)
 ;;=^^1^1^2940316^^
 ;;^UTILITY(U,$J,.84,8053,1,1,0)
 ;;=Prompt for the reader: End of page
 ;;^UTILITY(U,$J,.84,8053,2,0)
 ;;=^^1^1^2940316^^
 ;;^UTILITY(U,$J,.84,8053,2,1,0)
 ;;=Enter RETURN to continue or '^' to exit: 
 ;;^UTILITY(U,$J,.84,8053,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8054,0)
 ;;=8054^2^^11
 ;;^UTILITY(U,$J,.84,8054,1,0)
 ;;=^^1^1^2940310^^
 ;;^UTILITY(U,$J,.84,8054,1,1,0)
 ;;=Prompt for the reader: numbers
 ;;^UTILITY(U,$J,.84,8054,2,0)
 ;;=^^1^1^2940310^^
 ;;^UTILITY(U,$J,.84,8054,2,1,0)
 ;;=Enter a number
 ;;^UTILITY(U,$J,.84,8054,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8055,0)
 ;;=8055^2^^11
 ;;^UTILITY(U,$J,.84,8055,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8055,1,1,0)
 ;;=Prompt for the reader: date
 ;;^UTILITY(U,$J,.84,8055,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8055,2,1,0)
 ;;=Enter a date
 ;;^UTILITY(U,$J,.84,8055,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8056,0)
 ;;=8056^2^^11
 ;;^UTILITY(U,$J,.84,8056,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8056,1,1,0)
 ;;=Prompt for the reader: List
 ;;^UTILITY(U,$J,.84,8056,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8056,2,1,0)
 ;;=Enter a list or range of numbers
 ;;^UTILITY(U,$J,.84,8056,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8057,0)
 ;;=8057^2^^11
 ;;^UTILITY(U,$J,.84,8057,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8057,1,1,0)
 ;;=Prompt for the Reader: Pointers
 ;;^UTILITY(U,$J,.84,8057,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,8057,2,1,0)
 ;;=Select: 
 ;;^UTILITY(U,$J,.84,8057,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8058,0)
 ;;=8058^2^y^11^
 ;;^UTILITY(U,$J,.84,8058,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8058,1,1,0)
 ;;=Part II of the 'Are you adding a new...' question
 ;;^UTILITY(U,$J,.84,8058,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8058,2,1,0)
 ;;= (the |1|
 ;;^UTILITY(U,$J,.84,8058,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8058,3,1,0)
 ;;=1^Ordinal number of new entry
 ;;^UTILITY(U,$J,.84,8058,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8059,0)
 ;;=8059^2^y^11^

DINIT00N
DINIT00N ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8059,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8059,1,1,0)
 ;;=Part III of the 'Are you adding a new...' question
 ;;^UTILITY(U,$J,.84,8059,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8059,2,1,0)
 ;;= for this |1|
 ;;^UTILITY(U,$J,.84,8059,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8059,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8059,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8060,0)
 ;;=8060^2^^11
 ;;^UTILITY(U,$J,.84,8060,1,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8060,1,1,0)
 ;;=Part Ia of the 'Are you adding...' message
 ;;^UTILITY(U,$J,.84,8060,2,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8060,2,1,0)
 ;;=  Are you adding 
 ;;^UTILITY(U,$J,.84,8060,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8061,0)
 ;;=8061^2^y^11^
 ;;^UTILITY(U,$J,.84,8061,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8061,1,1,0)
 ;;=Part Ib of the 'Are you adding...' question
 ;;^UTILITY(U,$J,.84,8061,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8061,2,1,0)
 ;;='|1|' as 
 ;;^UTILITY(U,$J,.84,8061,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8061,3,1,0)
 ;;=1^Input value for .01 field
 ;;^UTILITY(U,$J,.84,8061,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8062,0)
 ;;=8062^2^y^11^
 ;;^UTILITY(U,$J,.84,8062,1,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,8062,1,1,0)
 ;;=Part Ic of the "Are you adding..." message
 ;;^UTILITY(U,$J,.84,8062,2,0)
 ;;=^^1^1^2940314^^^^
 ;;^UTILITY(U,$J,.84,8062,2,1,0)
 ;;=a new |1|
 ;;^UTILITY(U,$J,.84,8062,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8062,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8062,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8063,0)
 ;;=8063^2^y^11^
 ;;^UTILITY(U,$J,.84,8063,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8063,1,1,0)
 ;;=Lookup Part I
 ;;^UTILITY(U,$J,.84,8063,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8063,2,1,0)
 ;;= Answer with |1|
 ;;^UTILITY(U,$J,.84,8063,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8063,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8063,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8064,0)
 ;;=8064^2^^11
 ;;^UTILITY(U,$J,.84,8064,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8064,1,1,0)
 ;;=Lookup Part II
 ;;^UTILITY(U,$J,.84,8064,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8064,2,1,0)
 ;;= Do you want the entire 
 ;;^UTILITY(U,$J,.84,8064,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8065,0)
 ;;=8065^2^y^11^
 ;;^UTILITY(U,$J,.84,8065,1,0)
 ;;=^^1^1^2940314^^
 ;;^UTILITY(U,$J,.84,8065,1,1,0)
 ;;=Lookup Part III
 ;;^UTILITY(U,$J,.84,8065,2,0)
 ;;=^^1^1^2940314^^^
 ;;^UTILITY(U,$J,.84,8065,2,1,0)
 ;;=|1|-Entry 
 ;;^UTILITY(U,$J,.84,8065,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8065,3,1,0)
 ;;=1^Number of entries in list
 ;;^UTILITY(U,$J,.84,8065,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8066,0)
 ;;=8066^2^y^11^
 ;;^UTILITY(U,$J,.84,8066,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8066,1,1,0)
 ;;=Lookup Part IV
 ;;^UTILITY(U,$J,.84,8066,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8066,2,1,0)
 ;;=|1| List
 ;;^UTILITY(U,$J,.84,8066,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8066,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8066,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8067,0)
 ;;=8067^2^^11
 ;;^UTILITY(U,$J,.84,8067,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8067,1,1,0)
 ;;=For list of Fields on Lookup
 ;;^UTILITY(U,$J,.84,8067,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8067,2,1,0)
 ;;=, or
 ;;^UTILITY(U,$J,.84,8067,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8068,0)
 ;;=8068^2^^11
 ;;^UTILITY(U,$J,.84,8068,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8068,1,1,0)
 ;;=The Chooser
 ;;^UTILITY(U,$J,.84,8068,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8068,2,1,0)
 ;;=Choose from:
 ;;^UTILITY(U,$J,.84,8068,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8069,0)
 ;;=8069^2^y^11^
 ;;^UTILITY(U,$J,.84,8069,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8069,1,1,0)
 ;;=New entry allowed message
 ;;^UTILITY(U,$J,.84,8069,2,0)
 ;;=^^1^1^2940315^^
 ;;^UTILITY(U,$J,.84,8069,2,1,0)
 ;;=You may enter a new |1|, if you wish
 ;;^UTILITY(U,$J,.84,8069,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8069,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8069,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8070,0)
 ;;=8070^2^y^11^
 ;;^UTILITY(U,$J,.84,8070,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8070,1,1,0)
 ;;=Variable Pointer Lookup
 ;;^UTILITY(U,$J,.84,8070,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8070,2,1,0)
 ;;=     Searching for a |1|
 ;;^UTILITY(U,$J,.84,8070,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8070,3,1,0)
 ;;=1^Filename
 ;;^UTILITY(U,$J,.84,8070,4,0)
 ;;=^.847P^^0

DINIT00O
DINIT00O ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8071,0)
 ;;=8071^2^^11
 ;;^UTILITY(U,$J,.84,8071,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8071,1,1,0)
 ;;=Variable Pointer lookup
 ;;^UTILITY(U,$J,.84,8071,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8071,2,1,0)
 ;;=Enter one of the following:
 ;;^UTILITY(U,$J,.84,8071,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8072,0)
 ;;=8072^2^y^11^
 ;;^UTILITY(U,$J,.84,8072,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8072,1,1,0)
 ;;=Variable Pointer Lookup
 ;;^UTILITY(U,$J,.84,8072,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8072,2,1,0)
 ;;=  |1|.EntryName to select a |2|
 ;;^UTILITY(U,$J,.84,8072,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,8072,3,1,0)
 ;;=1^Prefix
 ;;^UTILITY(U,$J,.84,8072,3,2,0)
 ;;=2^Filename
 ;;^UTILITY(U,$J,.84,8072,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8073,0)
 ;;=8073^2^^11
 ;;^UTILITY(U,$J,.84,8073,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8073,1,1,0)
 ;;=Variable Pointer Lookup
 ;;^UTILITY(U,$J,.84,8073,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8073,2,1,0)
 ;;=To see the entries in any particular file type <Prefix.?>
 ;;^UTILITY(U,$J,.84,8073,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8074,0)
 ;;=8074^2^^11
 ;;^UTILITY(U,$J,.84,8074,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8074,1,1,0)
 ;;=How to call for help
 ;;^UTILITY(U,$J,.84,8074,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,8074,2,1,0)
 ;;=Press <PF1>H for help
 ;;^UTILITY(U,$J,.84,8074,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8075,0)
 ;;=8075^2^^11
 ;;^UTILITY(U,$J,.84,8075,1,0)
 ;;=^^1^1^2940524^^
 ;;^UTILITY(U,$J,.84,8075,1,1,0)
 ;;=Save changes question on form exit
 ;;^UTILITY(U,$J,.84,8075,2,0)
 ;;=^^1^1^2940524^^
 ;;^UTILITY(U,$J,.84,8075,2,1,0)
 ;;=Save changes before leaving form (Y/N)?
 ;;^UTILITY(U,$J,.84,8075,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8076,0)
 ;;=8076^2^^11
 ;;^UTILITY(U,$J,.84,8076,1,0)
 ;;=^^1^1^2940315^
 ;;^UTILITY(U,$J,.84,8076,1,1,0)
 ;;=Timeout
 ;;^UTILITY(U,$J,.84,8076,2,0)
 ;;=^^1^1^2940315^
 ;;^UTILITY(U,$J,.84,8076,2,1,0)
 ;;=Timed out.  
 ;;^UTILITY(U,$J,.84,8076,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8077,0)
 ;;=8077^2^^11
 ;;^UTILITY(U,$J,.84,8077,1,0)
 ;;=^^1^1^2940315^
 ;;^UTILITY(U,$J,.84,8077,1,1,0)
 ;;=Changes not saved on leaving form
 ;;^UTILITY(U,$J,.84,8077,2,0)
 ;;=^^1^1^2940315^
 ;;^UTILITY(U,$J,.84,8077,2,1,0)
 ;;=Changes not saved!
 ;;^UTILITY(U,$J,.84,8077,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8078,0)
 ;;=8078^2^^11
 ;;^UTILITY(U,$J,.84,8078,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8078,1,1,0)
 ;;=Wording for record
 ;;^UTILITY(U,$J,.84,8078,2,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8078,2,1,0)
 ;;=record
 ;;^UTILITY(U,$J,.84,8078,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8079,0)
 ;;=8079^2^^11
 ;;^UTILITY(U,$J,.84,8079,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8079,1,1,0)
 ;;=Wording for Subrecord
 ;;^UTILITY(U,$J,.84,8079,2,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8079,2,1,0)
 ;;=Subrecord
 ;;^UTILITY(U,$J,.84,8079,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8080,0)
 ;;=8080^2^y^11^
 ;;^UTILITY(U,$J,.84,8080,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8080,1,1,0)
 ;;=Warning for immediate deletion of entries.
 ;;^UTILITY(U,$J,.84,8080,2,0)
 ;;=^^3^3^2940316^
 ;;^UTILITY(U,$J,.84,8080,2,1,0)
 ;;=  WARNING: DELETIONS ARE DONE IMMEDIATELY!
 ;;^UTILITY(U,$J,.84,8080,2,2,0)
 ;;=           (EXITING WITHOUT SAVING WILL NOT RESTORE DELETED RECORDS.)
 ;;^UTILITY(U,$J,.84,8080,2,3,0)
 ;;=Are you sure you want to delete this entire |1| (Y/N)?
 ;;^UTILITY(U,$J,.84,8080,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8080,3,1,0)
 ;;=1^Record or Subrecord
 ;;^UTILITY(U,$J,.84,8080,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8081,0)
 ;;=8081^2^y^11^
 ;;^UTILITY(U,$J,.84,8081,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,8081,1,1,0)
 ;;=Choose from-to dialog
 ;;^UTILITY(U,$J,.84,8081,2,0)
 ;;=^^1^1^2940316^^
 ;;^UTILITY(U,$J,.84,8081,2,1,0)
 ;;=Choose |1| or '^' to quit: 
 ;;^UTILITY(U,$J,.84,8081,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,8081,3,1,0)
 ;;=1^Number range for selection
 ;;^UTILITY(U,$J,.84,8081,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,8082,0)
 ;;=8082^2^^11
 ;;^UTILITY(U,$J,.84,8082,1,0)
 ;;=^^2^2^2940318^^^^
 ;;^UTILITY(U,$J,.84,8082,1,1,0)
 ;;=Used to build error prompts in the TRANSFER/MERGE routine ^DIT3.  Could be
 ;;^UTILITY(U,$J,.84,8082,1,2,0)
 ;;=used elsewhere, however, so I didn't put it into the ERROR category.
 ;;^UTILITY(U,$J,.84,8082,2,0)
 ;;=^^1^1^2940318^
 ;;^UTILITY(U,$J,.84,8082,2,1,0)
 ;;=Transfer FROM

DINIT00P
DINIT00P ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,8082,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8082,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,8083,0)
 ;;=8083^2^^11
 ;;^UTILITY(U,$J,.84,8083,1,0)
 ;;=^^2^2^2940318^^^^
 ;;^UTILITY(U,$J,.84,8083,1,1,0)
 ;;=Used to build error prompts in the TRANSFER/MERGE routine ^DIT3.  Could be
 ;;^UTILITY(U,$J,.84,8083,1,2,0)
 ;;=used elsewhere, however, so I didn't put it into the ERROR category.
 ;;^UTILITY(U,$J,.84,8083,2,0)
 ;;=^^1^1^2940318^
 ;;^UTILITY(U,$J,.84,8083,2,1,0)
 ;;=Transfer TO
 ;;^UTILITY(U,$J,.84,8083,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8083,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,8084,0)
 ;;=8084^2^^11
 ;;^UTILITY(U,$J,.84,8084,1,0)
 ;;=^^1^1^2940318^
 ;;^UTILITY(U,$J,.84,8084,1,1,0)
 ;;=The words 'file number' to be used in any dialog.
 ;;^UTILITY(U,$J,.84,8084,2,0)
 ;;=^^1^1^2940318^
 ;;^UTILITY(U,$J,.84,8084,2,1,0)
 ;;=file number
 ;;^UTILITY(U,$J,.84,8084,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8084,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,8085,0)
 ;;=8085^2^^11
 ;;^UTILITY(U,$J,.84,8085,1,0)
 ;;=^^1^1^2940426^^
 ;;^UTILITY(U,$J,.84,8085,1,1,0)
 ;;=The words 'IEN string' to be used in any dialog.
 ;;^UTILITY(U,$J,.84,8085,2,0)
 ;;=^^1^1^2940426^^
 ;;^UTILITY(U,$J,.84,8085,2,1,0)
 ;;=IEN string
 ;;^UTILITY(U,$J,.84,8085,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,8085,5,1,0)
 ;;=DIT^TRNMRG
 ;;^UTILITY(U,$J,.84,8086,0)
 ;;=8086^2^^11
 ;;^UTILITY(U,$J,.84,8086,1,0)
 ;;=^^1^1^2940608^^^^
 ;;^UTILITY(U,$J,.84,8086,1,1,0)
 ;;=Warning to use the merge only during non-peak times.
 ;;^UTILITY(U,$J,.84,8086,2,0)
 ;;=^^5^5^2940608^
 ;;^UTILITY(U,$J,.84,8086,2,1,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8086,2,2,0)
 ;;=NOTE: Use this option ONLY DURING NON-PEAK HOURS if merging entries in a
 ;;^UTILITY(U,$J,.84,8086,2,3,0)
 ;;=file that is pointed-to either by many files, or by large files.
 ;;^UTILITY(U,$J,.84,8086,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,8086,2,5,0)
 ;;=MERGE ENTRIES AFTER COMPARING THEM 
 ;;^UTILITY(U,$J,.84,8086,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9002,0)
 ;;=9002^3^y^11^
 ;;^UTILITY(U,$J,.84,9002,1,0)
 ;;=^^1^1^2930617^^
 ;;^UTILITY(U,$J,.84,9002,1,1,0)
 ;;=Help for entering maximum routine size for compiled routines.
 ;;^UTILITY(U,$J,.84,9002,2,0)
 ;;=^^4^4^2930629^^^^
 ;;^UTILITY(U,$J,.84,9002,2,1,0)
 ;;=This number will be used to determine how large to make the generated
 ;;^UTILITY(U,$J,.84,9002,2,2,0)
 ;;=compiled |1| routines.  The size must be a number greater
 ;;^UTILITY(U,$J,.84,9002,2,3,0)
 ;;=than 2400, the larger the better, up to the maximum routine size for
 ;;^UTILITY(U,$J,.84,9002,2,4,0)
 ;;=your operating system.
 ;;^UTILITY(U,$J,.84,9002,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,9002,3,1,0)
 ;;=1^Will be the word 'TEMPLATE' when compiling templates, or 'cross-reference' when compiling CROSS-REFERENCES.
 ;;^UTILITY(U,$J,.84,9002,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9002,5,0)
 ;;=^.841^3^3
 ;;^UTILITY(U,$J,.84,9002,5,1,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,9002,5,2,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,9002,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,9004,0)
 ;;=9004^3^y^11^
 ;;^UTILITY(U,$J,.84,9004,1,0)
 ;;=^^2^2^2931110^^^^
 ;;^UTILITY(U,$J,.84,9004,1,1,0)
 ;;=Help asking the user whether they wish to UNCOMPILE previously compiled
 ;;^UTILITY(U,$J,.84,9004,1,2,0)
 ;;=templates or cross-references.
 ;;^UTILITY(U,$J,.84,9004,2,0)
 ;;=^^4^4^2931110^^
 ;;^UTILITY(U,$J,.84,9004,2,1,0)
 ;;=  Answer YES to UNCOMPILE the |1|.
 ;;^UTILITY(U,$J,.84,9004,2,2,0)
 ;;=The compiled routine will no longer be used.
 ;;^UTILITY(U,$J,.84,9004,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9004,2,4,0)
 ;;=  Answer NO to recompile the |1| at this time.
 ;;^UTILITY(U,$J,.84,9004,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,9004,3,1,0)
 ;;=1^Will contain either the word 'TEMPLATE' or 'CROSS-REFERENCES.
 ;;^UTILITY(U,$J,.84,9004,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9004,5,0)
 ;;=^.841^3^3
 ;;^UTILITY(U,$J,.84,9004,5,1,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,9004,5,2,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,9004,5,3,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,9006,0)
 ;;=9006^3^y^11^
 ;;^UTILITY(U,$J,.84,9006,1,0)
 ;;=^^2^2^2931105^^^^
 ;;^UTILITY(U,$J,.84,9006,1,1,0)
 ;;=Help for prompting for compiled routine name, when compiling templates
 ;;^UTILITY(U,$J,.84,9006,1,2,0)
 ;;=or cross-references.
 ;;^UTILITY(U,$J,.84,9006,2,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,9006,2,1,0)
 ;;=Enter a valid MUMPS routine name of from 3 to |1| characters.  This must

DINIT00Q
DINIT00Q ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9006,2,2,0)
 ;;=be entered without a leading up-arrow, and cannot begin with "DI".
 ;;^UTILITY(U,$J,.84,9006,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,9006,3,1,0)
 ;;=1^Internal parameter indicating the maximum number of characters allowed for routine namespace.
 ;;^UTILITY(U,$J,.84,9006,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9006,5,0)
 ;;=^.841^4^4
 ;;^UTILITY(U,$J,.84,9006,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9006,5,2,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,9006,5,3,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,9006,5,4,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,9014,0)
 ;;=9014^3^^11^
 ;;^UTILITY(U,$J,.84,9014,1,0)
 ;;=^^1^1^2930706^^^^
 ;;^UTILITY(U,$J,.84,9014,1,1,0)
 ;;=Help prompt for compiling sort templates.
 ;;^UTILITY(U,$J,.84,9014,2,0)
 ;;=^^3^3^2931110^
 ;;^UTILITY(U,$J,.84,9014,2,1,0)
 ;;=If YES is entered,
 ;;^UTILITY(U,$J,.84,9014,2,2,0)
 ;;=the Sort logic will be compiled into a routine at the
 ;;^UTILITY(U,$J,.84,9014,2,3,0)
 ;;=time the template is used in a FileMan Sort/Print.
 ;;^UTILITY(U,$J,.84,9014,3,0)
 ;;=^.845^^0
 ;;^UTILITY(U,$J,.84,9014,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9014,5,1,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,9019,0)
 ;;=9019^3^^11^
 ;;^UTILITY(U,$J,.84,9019,1,0)
 ;;=^^1^1^2931110^^^^
 ;;^UTILITY(U,$J,.84,9019,1,1,0)
 ;;=Help prompt for Uncompiling sort templates.
 ;;^UTILITY(U,$J,.84,9019,2,0)
 ;;=^^3^3^2931110^
 ;;^UTILITY(U,$J,.84,9019,2,1,0)
 ;;=If YES is entered,
 ;;^UTILITY(U,$J,.84,9019,2,2,0)
 ;;=the Sort logic for this template will NOT be compiled into a
 ;;^UTILITY(U,$J,.84,9019,2,3,0)
 ;;=routine during the time it is used by a FileMan sort/print.
 ;;^UTILITY(U,$J,.84,9019,3,0)
 ;;=^.845^^0
 ;;^UTILITY(U,$J,.84,9019,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9019,5,1,0)
 ;;=DIOZ^ENCU
 ;;^UTILITY(U,$J,.84,9024,0)
 ;;=9024^3^^11^
 ;;^UTILITY(U,$J,.84,9024,1,0)
 ;;=^^2^2^2931105^
 ;;^UTILITY(U,$J,.84,9024,1,1,0)
 ;;=Help for the POST-SELECTION ACTION field for a file.  This entry is put
 ;;^UTILITY(U,$J,.84,9024,1,2,0)
 ;;=in from the Utility option to edit a file.
 ;;^UTILITY(U,$J,.84,9024,2,0)
 ;;=^^1^1^2931105^^^
 ;;^UTILITY(U,$J,.84,9024,2,1,0)
 ;;=This code will be executed whenever an entry is selected from the file.
 ;;^UTILITY(U,$J,.84,9024,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9024,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9025,0)
 ;;=9025^3^^11^
 ;;^UTILITY(U,$J,.84,9025,1,0)
 ;;=^^1^1^2931105^^
 ;;^UTILITY(U,$J,.84,9025,1,1,0)
 ;;=General help for MUMPS type fields.
 ;;^UTILITY(U,$J,.84,9025,2,0)
 ;;=^^1^1^2931105^
 ;;^UTILITY(U,$J,.84,9025,2,1,0)
 ;;=Enter a line of standard MUMPS code.
 ;;^UTILITY(U,$J,.84,9025,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9025,5,1,0)
 ;;=DIOU^6
 ;;^UTILITY(U,$J,.84,9026,0)
 ;;=9026^3^^11
 ;;^UTILITY(U,$J,.84,9026,1,0)
 ;;=^^3^3^2931105^^
 ;;^UTILITY(U,$J,.84,9026,1,1,0)
 ;;=The DD for the file of files is not completely FileMan compatible.  This
 ;;^UTILITY(U,$J,.84,9026,1,2,0)
 ;;=is the standard help prompt for the LOOK-UP PROGRAM field on the file of
 ;;^UTILITY(U,$J,.84,9026,1,3,0)
 ;;=files.  Prompt appears when file attributes are being edited.
 ;;^UTILITY(U,$J,.84,9026,2,0)
 ;;=^^2^2^2931105^^
 ;;^UTILITY(U,$J,.84,9026,2,1,0)
 ;;=This special lookup routine will be executed instead of the standard
 ;;^UTILITY(U,$J,.84,9026,2,2,0)
 ;;=FileMan lookup logic, whenever a call is made to ^DIC.
 ;;^UTILITY(U,$J,.84,9026,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9026,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9027,0)
 ;;=9027^3^^11
 ;;^UTILITY(U,$J,.84,9027,1,0)
 ;;=^^3^3^2931105^
 ;;^UTILITY(U,$J,.84,9027,1,1,0)
 ;;=The DD for the file of files is not completely FileMan compatible.  This
 ;;^UTILITY(U,$J,.84,9027,1,2,0)
 ;;=is the standard help prompt for the CROSS-REFERENCE ROUTINE field on the
 ;;^UTILITY(U,$J,.84,9027,1,3,0)
 ;;=file of files.  Prompt appears when file attributes are being edited.
 ;;^UTILITY(U,$J,.84,9027,2,0)
 ;;=^^5^5^2931109^
 ;;^UTILITY(U,$J,.84,9027,2,1,0)
 ;;=If a NEW routine name is entered, but the cross-references are not
 ;;^UTILITY(U,$J,.84,9027,2,2,0)
 ;;=compiled at this time, the routine name will be automatically deleted.
 ;;^UTILITY(U,$J,.84,9027,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9027,2,4,0)
 ;;=If the routine name is deleted, the cross-references are considered
 ;;^UTILITY(U,$J,.84,9027,2,5,0)
 ;;=uncompiled, and FileMan will not use the routine for re-indexing.
 ;;^UTILITY(U,$J,.84,9027,5,0)
 ;;=^.841^1^1

DINIT00R
DINIT00R ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9027,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9028,0)
 ;;=9028^3^^11
 ;;^UTILITY(U,$J,.84,9028,1,0)
 ;;=^^3^3^2931109^
 ;;^UTILITY(U,$J,.84,9028,1,1,0)
 ;;=Help prompt for CROSS-REFERENCE ROUTINE name when editing file attributes.
 ;;^UTILITY(U,$J,.84,9028,1,2,0)
 ;;= If the user does not changes the name of the CROSS-REFERENCE ROUTINE,
 ;;^UTILITY(U,$J,.84,9028,1,3,0)
 ;;=then recompilation is not required, and they will see this help prompt.
 ;;^UTILITY(U,$J,.84,9028,2,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,9028,2,1,0)
 ;;=It is not necessary to recompile the cross-references, since the name of
 ;;^UTILITY(U,$J,.84,9028,2,2,0)
 ;;=the CROSS-REFERENCE ROUTINE was not changed.
 ;;^UTILITY(U,$J,.84,9028,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9028,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9029,0)
 ;;=9029^3^^11
 ;;^UTILITY(U,$J,.84,9029,1,0)
 ;;=^^5^5^2931109^
 ;;^UTILITY(U,$J,.84,9029,1,1,0)
 ;;=Help prompt for CROSS-REFERENCE ROUTINE name when editing file attributes.
 ;;^UTILITY(U,$J,.84,9029,1,2,0)
 ;;= If the user changes the name of the CROSS-REFERENCE ROUTINE, or enters a
 ;;^UTILITY(U,$J,.84,9029,1,3,0)
 ;;=name for the first time, they must also compile the routines at this time.
 ;;^UTILITY(U,$J,.84,9029,1,4,0)
 ;;= If they don't the routine name they just entered will be deleted from the
 ;;^UTILITY(U,$J,.84,9029,1,5,0)
 ;;=DD.
 ;;^UTILITY(U,$J,.84,9029,2,0)
 ;;=^^2^2^2931109^
 ;;^UTILITY(U,$J,.84,9029,2,1,0)
 ;;=If the cross-references are not recompiled at this time, the
 ;;^UTILITY(U,$J,.84,9029,2,2,0)
 ;;=CROSS-REFERENCE ROUTINE name will NOT be saved in the data dictionary.
 ;;^UTILITY(U,$J,.84,9029,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9029,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9030,0)
 ;;=9030^3^^11^
 ;;^UTILITY(U,$J,.84,9030,1,0)
 ;;=^^2^2^2931109^^^^
 ;;^UTILITY(U,$J,.84,9030,1,1,0)
 ;;=Help for prompting for compiled routine name, when compiling templates
 ;;^UTILITY(U,$J,.84,9030,1,2,0)
 ;;=or cross-references.
 ;;^UTILITY(U,$J,.84,9030,2,0)
 ;;=^^1^1^2931109^
 ;;^UTILITY(U,$J,.84,9030,2,1,0)
 ;;=This will become the namespace of the compiled routine(s).
 ;;^UTILITY(U,$J,.84,9030,3,0)
 ;;=^.845^^0
 ;;^UTILITY(U,$J,.84,9030,5,0)
 ;;=^.841^4^4
 ;;^UTILITY(U,$J,.84,9030,5,1,0)
 ;;=DIU0^6
 ;;^UTILITY(U,$J,.84,9030,5,2,0)
 ;;=DIKZ^ 
 ;;^UTILITY(U,$J,.84,9030,5,3,0)
 ;;=DIPZ^ 
 ;;^UTILITY(U,$J,.84,9030,5,4,0)
 ;;=DIEZ^ 
 ;;^UTILITY(U,$J,.84,9031,0)
 ;;=9031^2^^11
 ;;^UTILITY(U,$J,.84,9031,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9031,1,1,0)
 ;;=Help for the reader: Freetext
 ;;^UTILITY(U,$J,.84,9031,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9031,2,1,0)
 ;;=This response can be free text
 ;;^UTILITY(U,$J,.84,9031,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9032,0)
 ;;=9032^2^^11
 ;;^UTILITY(U,$J,.84,9032,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9032,1,1,0)
 ;;=Help for the reader: Set of codes
 ;;^UTILITY(U,$J,.84,9032,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9032,2,1,0)
 ;;=Enter a code from the list.
 ;;^UTILITY(U,$J,.84,9032,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9033,0)
 ;;=9033^2^^11
 ;;^UTILITY(U,$J,.84,9033,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9033,1,1,0)
 ;;=Help for the reader: End of page
 ;;^UTILITY(U,$J,.84,9033,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9033,2,1,0)
 ;;=Enter either RETURN or '^'
 ;;^UTILITY(U,$J,.84,9033,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9034,0)
 ;;=9034^2^^11
 ;;^UTILITY(U,$J,.84,9034,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9034,1,1,0)
 ;;=Help for the reader: Numbers
 ;;^UTILITY(U,$J,.84,9034,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9034,2,1,0)
 ;;=This response must be a number
 ;;^UTILITY(U,$J,.84,9034,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9035,0)
 ;;=9035^2^^11
 ;;^UTILITY(U,$J,.84,9035,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9035,1,1,0)
 ;;=Help for the reader: dates
 ;;^UTILITY(U,$J,.84,9035,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9035,2,1,0)
 ;;=This response must be a date
 ;;^UTILITY(U,$J,.84,9035,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9036,0)
 ;;=9036^2^^11
 ;;^UTILITY(U,$J,.84,9036,1,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9036,1,1,0)
 ;;=Help for the reader: List
 ;;^UTILITY(U,$J,.84,9036,2,0)
 ;;=^^1^1^2940310^
 ;;^UTILITY(U,$J,.84,9036,2,1,0)
 ;;=This response must be a list or range, e.g., 1,3,5 or 2-4,8
 ;;^UTILITY(U,$J,.84,9036,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9037,0)
 ;;=9037^3^^11

DINIT00S
DINIT00S ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9037,1,0)
 ;;=^^1^1^2940316^^
 ;;^UTILITY(U,$J,.84,9037,1,1,0)
 ;;=Help for leaving form
 ;;^UTILITY(U,$J,.84,9037,2,0)
 ;;=^^3^3^2940316^^
 ;;^UTILITY(U,$J,.84,9037,2,1,0)
 ;;=Enter 'Y' to save before exiting.
 ;;^UTILITY(U,$J,.84,9037,2,2,0)
 ;;=Enter 'N' or '^' to exit without saving.
 ;;^UTILITY(U,$J,.84,9037,2,3,0)
 ;;=Press 'RETURN' to return to form
 ;;^UTILITY(U,$J,.84,9038,0)
 ;;=9038^3^^11
 ;;^UTILITY(U,$J,.84,9038,1,0)
 ;;=^^1^1^2940316^
 ;;^UTILITY(U,$J,.84,9038,1,1,0)
 ;;=Help for (Sub)record delete in forms
 ;;^UTILITY(U,$J,.84,9038,2,0)
 ;;=^^2^2^2940316^
 ;;^UTILITY(U,$J,.84,9038,2,1,0)
 ;;=Enter 'Y' to delete.
 ;;^UTILITY(U,$J,.84,9038,2,2,0)
 ;;=Enter 'N' or 'RETURN' to return to form.
 ;;^UTILITY(U,$J,.84,9038,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9040,0)
 ;;=9040^2^^11
 ;;^UTILITY(U,$J,.84,9040,1,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,9040,1,1,0)
 ;;=Reader Help for Yes/No question
 ;;^UTILITY(U,$J,.84,9040,2,0)
 ;;=^^1^1^2940314^
 ;;^UTILITY(U,$J,.84,9040,2,1,0)
 ;;=Enter either 'Y' or 'N'.
 ;;^UTILITY(U,$J,.84,9040,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,9041,0)
 ;;=9041^3^^11
 ;;^UTILITY(U,$J,.84,9041,1,0)
 ;;=^^2^2^2940608^^^^
 ;;^UTILITY(U,$J,.84,9041,1,1,0)
 ;;=Help message for why the Compare/Merge options should be run during
 ;;^UTILITY(U,$J,.84,9041,1,2,0)
 ;;=non-peak hours.
 ;;^UTILITY(U,$J,.84,9041,2,0)
 ;;=^^8^8^2940608^
 ;;^UTILITY(U,$J,.84,9041,2,1,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9041,2,2,0)
 ;;=Enter 'NO' to compare and display the two entries.
 ;;^UTILITY(U,$J,.84,9041,2,3,0)
 ;;=Enter 'YES' to choose valid fields from each entry then merge into the
 ;;^UTILITY(U,$J,.84,9041,2,4,0)
 ;;=record selected as the default.
 ;;^UTILITY(U,$J,.84,9041,2,5,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9041,2,6,0)
 ;;=If you merge two entries within a file that is pointed-to by many other
 ;;^UTILITY(U,$J,.84,9041,2,7,0)
 ;;=files (such as the PATIENT file), then the re-pointing process can be time
 ;;^UTILITY(U,$J,.84,9041,2,8,0)
 ;;=consuming and can create many tasked jobs.
 ;;^UTILITY(U,$J,.84,9101,0)
 ;;=9101^3^^11
 ;;^UTILITY(U,$J,.84,9101,1,0)
 ;;=^^1^1^2930810^
 ;;^UTILITY(U,$J,.84,9101,1,1,0)
 ;;=The "CHOOSE FROM:" prompt.
 ;;^UTILITY(U,$J,.84,9101,2,0)
 ;;=^^1^1^2930908^^
 ;;^UTILITY(U,$J,.84,9101,2,1,0)
 ;;=Choose from:
 ;;^UTILITY(U,$J,.84,9103,0)
 ;;=9103^3^^11
 ;;^UTILITY(U,$J,.84,9103,1,0)
 ;;=^^2^2^2930810^^
 ;;^UTILITY(U,$J,.84,9103,1,1,0)
 ;;=First line of Variable Pointer help that shows the Prefixes and Messages
 ;;^UTILITY(U,$J,.84,9103,1,2,0)
 ;;=for a field.
 ;;^UTILITY(U,$J,.84,9103,2,0)
 ;;=^^1^1^2930810^
 ;;^UTILITY(U,$J,.84,9103,2,1,0)
 ;;=Enter one of the following:
 ;;^UTILITY(U,$J,.84,9105,0)
 ;;=9105^3^y^11^
 ;;^UTILITY(U,$J,.84,9105,1,0)
 ;;=^^2^2^2931229^
 ;;^UTILITY(U,$J,.84,9105,1,1,0)
 ;;=The beginning of the help text used to give list of fields that can
 ;;^UTILITY(U,$J,.84,9105,1,2,0)
 ;;=be used for a look-up.
 ;;^UTILITY(U,$J,.84,9105,2,0)
 ;;=^^1^1^2931229^
 ;;^UTILITY(U,$J,.84,9105,2,1,0)
 ;;=Answer with |1|.
 ;;^UTILITY(U,$J,.84,9105,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,9105,3,1,0)
 ;;=1^File name and list of fields that can be used for look-up.
 ;;^UTILITY(U,$J,.84,9105,5,0)
 ;;=^.841^1^1
 ;;^UTILITY(U,$J,.84,9105,5,1,0)
 ;;=DIE^HELP
 ;;^UTILITY(U,$J,.84,9107,0)
 ;;=9107^3^y^11^
 ;;^UTILITY(U,$J,.84,9107,1,0)
 ;;=^^1^1^2940513^
 ;;^UTILITY(U,$J,.84,9107,1,1,0)
 ;;=LAYGO allowed.
 ;;^UTILITY(U,$J,.84,9107,2,0)
 ;;=^^1^1^2940513^
 ;;^UTILITY(U,$J,.84,9107,2,1,0)
 ;;=You may enter a new |1| if you wish.
 ;;^UTILITY(U,$J,.84,9107,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,9107,3,1,0)
 ;;=1^File Name.
 ;;^UTILITY(U,$J,.84,9110,0)
 ;;=9110^3^y^11^
 ;;^UTILITY(U,$J,.84,9110,1,0)
 ;;=^^1^1^2940223^^
 ;;^UTILITY(U,$J,.84,9110,1,1,0)
 ;;=Instructions for entering date data.
 ;;^UTILITY(U,$J,.84,9110,2,0)
 ;;=^^6^6^2940223^^^
 ;;^UTILITY(U,$J,.84,9110,2,1,0)
 ;;=Examples of Valid Dates:
 ;;^UTILITY(U,$J,.84,9110,2,2,0)
 ;;=   JAN 20 1957 or JAN 57 or 1/20/57 |1|
 ;;^UTILITY(U,$J,.84,9110,2,3,0)
 ;;=   T   (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc.
 ;;^UTILITY(U,$J,.84,9110,2,4,0)
 ;;=T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc.
 ;;^UTILITY(U,$J,.84,9110,2,5,0)
 ;;=If the year is omitted, the computer |2|.
 ;;^UTILITY(U,$J,.84,9110,2,6,0)
 ;;=|3|
 ;;^UTILITY(U,$J,.84,9110,3,0)
 ;;=^.845^3^3
 ;;^UTILITY(U,$J,.84,9110,3,1,0)
 ;;=1^If numeric dates are allowed, " or 012057" is written.

DINIT00T
DINIT00T ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9110,3,2,0)
 ;;=2^Conditionally, indicates if past, future, or current year is assumed.
 ;;^UTILITY(U,$J,.84,9110,3,3,0)
 ;;=3^Conditionally, indicates that day is not needed.
 ;;^UTILITY(U,$J,.84,9111,0)
 ;;=9111^3^y^11^
 ;;^UTILITY(U,$J,.84,9111,1,0)
 ;;=^^1^1^2930806^
 ;;^UTILITY(U,$J,.84,9111,1,1,0)
 ;;=Instructions for entering time data.
 ;;^UTILITY(U,$J,.84,9111,2,0)
 ;;=^^5^5^2931104^^
 ;;^UTILITY(U,$J,.84,9111,2,1,0)
 ;;=If the date is omitted, the current date is assumed.
 ;;^UTILITY(U,$J,.84,9111,2,2,0)
 ;;=Follow the date with a time, such as JAN 20@10, T@10AM, 10:30, etc.
 ;;^UTILITY(U,$J,.84,9111,2,3,0)
 ;;=You may enter NOON, MIDNIGHT, or NOW to indicate the time.
 ;;^UTILITY(U,$J,.84,9111,2,4,0)
 ;;=|1|
 ;;^UTILITY(U,$J,.84,9111,2,5,0)
 ;;=|2|
 ;;^UTILITY(U,$J,.84,9111,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,9111,3,1,0)
 ;;=1^Conditionally, give instructions for entering seconds.
 ;;^UTILITY(U,$J,.84,9111,3,2,0)
 ;;=2^Conditionally, state that time is required.
 ;;^UTILITY(U,$J,.84,9115,0)
 ;;=9115^3^^11
 ;;^UTILITY(U,$J,.84,9115,1,0)
 ;;=^^1^1^2930810^
 ;;^UTILITY(U,$J,.84,9115,1,1,0)
 ;;=The short help for variable pointers.
 ;;^UTILITY(U,$J,.84,9115,2,0)
 ;;=^^1^1^2930810^
 ;;^UTILITY(U,$J,.84,9115,2,1,0)
 ;;=To see the entries in any particular file, type <Prefix.?>.
 ;;^UTILITY(U,$J,.84,9116,0)
 ;;=9116^3^^11
 ;;^UTILITY(U,$J,.84,9116,1,0)
 ;;=^^1^1^2930810^
 ;;^UTILITY(U,$J,.84,9116,1,1,0)
 ;;=Long help for variable pointers.
 ;;^UTILITY(U,$J,.84,9116,2,0)
 ;;=^^15^15^2930810^
 ;;^UTILITY(U,$J,.84,9116,2,1,0)
 ;;=If you enter just a name, the system will search each of the 
 ;;^UTILITY(U,$J,.84,9116,2,2,0)
 ;;=above files for the name you have entered.  If a match is found,
 ;;^UTILITY(U,$J,.84,9116,2,3,0)
 ;;=the system will ask you if it is the entry you desire.
 ;;^UTILITY(U,$J,.84,9116,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9116,2,5,0)
 ;;=However, if you know the file the entry should be in, you can
 ;;^UTILITY(U,$J,.84,9116,2,6,0)
 ;;=speed processing by using the following syntax to select an entry:
 ;;^UTILITY(U,$J,.84,9116,2,7,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9116,2,8,0)
 ;;=     <Prefix>.<entry name>
 ;;^UTILITY(U,$J,.84,9116,2,9,0)
 ;;=             or
 ;;^UTILITY(U,$J,.84,9116,2,10,0)
 ;;=     <Message>.<entry name>
 ;;^UTILITY(U,$J,.84,9116,2,11,0)
 ;;=             or
 ;;^UTILITY(U,$J,.84,9116,2,12,0)
 ;;=     <File Name>.<entry name>
 ;;^UTILITY(U,$J,.84,9116,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9116,2,14,0)
 ;;=You do not need to enter the entire file name or message.
 ;;^UTILITY(U,$J,.84,9116,2,15,0)
 ;;=The first few characters will suffice.
 ;;^UTILITY(U,$J,.84,9117,0)
 ;;=9117^3^y^11^
 ;;^UTILITY(U,$J,.84,9117,1,0)
 ;;=^^1^1^2930810^^
 ;;^UTILITY(U,$J,.84,9117,1,1,0)
 ;;=Variable pointer help - prefix and message.
 ;;^UTILITY(U,$J,.84,9117,2,0)
 ;;=^^1^1^2930810^^^
 ;;^UTILITY(U,$J,.84,9117,2,1,0)
 ;;=|1|.EntryName to select a |2|.
 ;;^UTILITY(U,$J,.84,9117,3,0)
 ;;=^.845^2^2
 ;;^UTILITY(U,$J,.84,9117,3,1,0)
 ;;=1^The prefix for a variable pointer file.
 ;;^UTILITY(U,$J,.84,9117,3,2,0)
 ;;=2^The message for a variable pointer file.
 ;;^UTILITY(U,$J,.84,9201,0)
 ;;=9201^3^^11
 ;;^UTILITY(U,$J,.84,9201,1,0)
 ;;=^^1^1^2941024^
 ;;^UTILITY(U,$J,.84,9201,1,1,0)
 ;;=Browser help
 ;;^UTILITY(U,$J,.84,9201,2,0)
 ;;=^^180^180^2941024^
 ;;^UTILITY(U,$J,.84,9201,2,1,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,2,0)
 ;;=                                  HELP SUMMARY
 ;;^UTILITY(U,$J,.84,9201,2,3,0)
 ;;=                                  ============
 ;;^UTILITY(U,$J,.84,9201,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,5,0)
 ;;=NAVIGATION:
 ;;^UTILITY(U,$J,.84,9201,2,6,0)
 ;;============
 ;;^UTILITY(U,$J,.84,9201,2,7,0)
 ;;=     Scroll Down (one line)                  ARROW DOWN
 ;;^UTILITY(U,$J,.84,9201,2,8,0)
 ;;=     Scroll Up (one line)                    ARROW UP
 ;;^UTILITY(U,$J,.84,9201,2,9,0)
 ;;=     Page Down                               <PF1>ARROW DOWN
 ;;^UTILITY(U,$J,.84,9201,2,10,0)
 ;;=     Page Up                                 <PF1>ARROW UP
 ;;^UTILITY(U,$J,.84,9201,2,11,0)
 ;;=     Scroll Right (default 22 columns)       ARROW RIGHT
 ;;^UTILITY(U,$J,.84,9201,2,12,0)
 ;;=     Scroll Left (default 22 columns)        ARROW LEFT
 ;;^UTILITY(U,$J,.84,9201,2,13,0)
 ;;=     Scroll Horizontally to the end          <PF1>ARROW RIGHT
 ;;^UTILITY(U,$J,.84,9201,2,14,0)
 ;;=     Scroll Horizontally to the end          <PF1>ARROW LEFT

DINIT00U
DINIT00U ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9201,2,15,0)
 ;;=     Jump to the Top                         <PF1>T
 ;;^UTILITY(U,$J,.84,9201,2,16,0)
 ;;=     Jump to the Bottom                      <PF1>B
 ;;^UTILITY(U,$J,.84,9201,2,17,0)
 ;;=     Goto                                    <PF1>G
 ;;^UTILITY(U,$J,.84,9201,2,18,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,19,0)
 ;;=SEARCH:
 ;;^UTILITY(U,$J,.84,9201,2,20,0)
 ;;========
 ;;^UTILITY(U,$J,.84,9201,2,21,0)
 ;;=     Find text                               <PF1>F
 ;;^UTILITY(U,$J,.84,9201,2,22,0)
 ;;=     Next (occurrence)                       <PF1>N
 ;;^UTILITY(U,$J,.84,9201,2,23,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,24,0)
 ;;=     Direction-terminate find text with:
 ;;^UTILITY(U,$J,.84,9201,2,25,0)
 ;;=     -----------------------------------
 ;;^UTILITY(U,$J,.84,9201,2,26,0)
 ;;=     Down                                    ARROW DOWN
 ;;^UTILITY(U,$J,.84,9201,2,27,0)
 ;;=     Up                                      ARROW UP
 ;;^UTILITY(U,$J,.84,9201,2,28,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,29,0)
 ;;=BRANCH:
 ;;^UTILITY(U,$J,.84,9201,2,30,0)
 ;;========
 ;;^UTILITY(U,$J,.84,9201,2,31,0)
 ;;=     Switch to another document              <PF1>S
 ;;^UTILITY(U,$J,.84,9201,2,32,0)
 ;;=     Return to previous document(s)          R
 ;;^UTILITY(U,$J,.84,9201,2,33,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,34,0)
 ;;=SCREEN:
 ;;^UTILITY(U,$J,.84,9201,2,35,0)
 ;;========
 ;;^UTILITY(U,$J,.84,9201,2,36,0)
 ;;=     Repaint screen                          <PF1>P
 ;;^UTILITY(U,$J,.84,9201,2,37,0)
 ;;=     Split screen                            <PF2>S
 ;;^UTILITY(U,$J,.84,9201,2,38,0)
 ;;=     restore Full screen                     <PF2>F
 ;;^UTILITY(U,$J,.84,9201,2,39,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,40,0)
 ;;=     Split Screen Mode Navigation:
 ;;^UTILITY(U,$J,.84,9201,2,41,0)
 ;;=     -----------------------------
 ;;^UTILITY(U,$J,.84,9201,2,42,0)
 ;;=     Navigate to bottom screen              <PF2>ARROW DOWN
 ;;^UTILITY(U,$J,.84,9201,2,43,0)
 ;;=     Navigate to top screen                 <PF2>ARROW UP
 ;;^UTILITY(U,$J,.84,9201,2,44,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,45,0)
 ;;=     Resize Split Screen:
 ;;^UTILITY(U,$J,.84,9201,2,46,0)
 ;;=     --------------------
 ;;^UTILITY(U,$J,.84,9201,2,47,0)
 ;;=     Top/Bottom screen larger/smaller       <PF2><PF2>ARROW DOWN
 ;;^UTILITY(U,$J,.84,9201,2,48,0)
 ;;=     Bottom/Top screen larger/smaller       <PF2><PF2>ARROW UP
 ;;^UTILITY(U,$J,.84,9201,2,49,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,50,0)
 ;;=HELP:
 ;;^UTILITY(U,$J,.84,9201,2,51,0)
 ;;======
 ;;^UTILITY(U,$J,.84,9201,2,52,0)
 ;;=     Browse Key Summary                     <PF1>H
 ;;^UTILITY(U,$J,.84,9201,2,53,0)
 ;;=     More Help                              <PF1><PF1>H
 ;;^UTILITY(U,$J,.84,9201,2,54,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,55,0)
 ;;=EXIT:
 ;;^UTILITY(U,$J,.84,9201,2,56,0)
 ;;======
 ;;^UTILITY(U,$J,.84,9201,2,57,0)
 ;;=     Exit Browser or help text              <PF1>E or "EXIT"
 ;;^UTILITY(U,$J,.84,9201,2,58,0)
 ;;=     Quit                                   <PF1>Q
 ;;^UTILITY(U,$J,.84,9201,2,59,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,60,0)
 ;;=                                    More Help
 ;;^UTILITY(U,$J,.84,9201,2,61,0)
 ;;=                                    =========
 ;;^UTILITY(U,$J,.84,9201,2,62,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,63,0)
 ;;=     To EXIT the VA FileMan Browser, press <PF1> followed by the letter
 ;;^UTILITY(U,$J,.84,9201,2,64,0)
 ;;=     'E'.  This is also true for this HELP document which is being
 ;;^UTILITY(U,$J,.84,9201,2,65,0)
 ;;=     presented by the Browser.
 ;;^UTILITY(U,$J,.84,9201,2,66,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,67,0)
 ;;=     To SCROLL DOWN one line at a time, press the ARROW DOWN key.
 ;;^UTILITY(U,$J,.84,9201,2,68,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,69,0)
 ;;=     To SCROLL UP one line at a time, press the ARROW UP key.
 ;;^UTILITY(U,$J,.84,9201,2,70,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,71,0)
 ;;=     To SCROLL RIGHT, press the ARROW RIGHT key.
 ;;^UTILITY(U,$J,.84,9201,2,72,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,73,0)
 ;;=     To SCROLL LEFT, press the ARROW LEFT key.
 ;;^UTILITY(U,$J,.84,9201,2,74,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,75,0)
 ;;=     Try pressing these keys at this time and observe the behavior. Get a
 ;;^UTILITY(U,$J,.84,9201,2,76,0)
 ;;=     feel for 'browsing' through a document.  Press the arrow down key a

DINIT00V
DINIT00V ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9201,2,77,0)
 ;;=     few times, then press the arrow up key.  Also notice that the 'Line>'
 ;;^UTILITY(U,$J,.84,9201,2,78,0)
 ;;=     and 'Screen>' indicator numbers are changing. To see more of this
 ;;^UTILITY(U,$J,.84,9201,2,79,0)
 ;;=     text keep pressing the ARROW DOWN key.  Now try the arrow right key,
 ;;^UTILITY(U,$J,.84,9201,2,80,0)
 ;;=     then the arrow left key.  Notice that the 'Col>' indicator number is
 ;;^UTILITY(U,$J,.84,9201,2,81,0)
 ;;=     also changing.  This shows what column the left most edge of the
 ;;^UTILITY(U,$J,.84,9201,2,82,0)
 ;;=     document is on.  As you can see, the VA FileMan Browser is like a
 ;;^UTILITY(U,$J,.84,9201,2,83,0)
 ;;=     window placed over a document. You are in control of this window
 ;;^UTILITY(U,$J,.84,9201,2,84,0)
 ;;=     which moves over the document by pressing the functional key
 ;;^UTILITY(U,$J,.84,9201,2,85,0)
 ;;=     sequences.  Here are a few more functions.
 ;;^UTILITY(U,$J,.84,9201,2,86,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9201,2,87,0)
 ;;=     To PAGE DOWN one screen at one time, press the NEXT SCREEN key, PAGE
 ;;^UTILITY(U,$J,.84,9201,2,88,0)
 ;;=     DOWN or PF1 followed by the ARROW DOWN key, depending on what kind of
 ;;^UTILITY(U,$J,.84,9201,2,89,0)
 ;;=     CRT or workstation that is being used.
 ;;^UTILITY(U,$J,.84,9201,2,90,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,91,0)
 ;;=     To PAGE UP one screen at one time, press the PREV SCREEN key, PAGE UP
 ;;^UTILITY(U,$J,.84,9201,2,92,0)
 ;;=     or PF1 followed by the ARROW UP key, depending on what kind of CRT or
 ;;^UTILITY(U,$J,.84,9201,2,93,0)
 ;;=     workstation that is being used.
 ;;^UTILITY(U,$J,.84,9201,2,94,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,95,0)
 ;;=     To return to the TOP, back to the beginning of the document, press
 ;;^UTILITY(U,$J,.84,9201,2,96,0)
 ;;=     the <PF1> key followed by the letter 'T'.
 ;;^UTILITY(U,$J,.84,9201,2,97,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,98,0)
 ;;=     To go to the BOTTOM, end of the document, press the <PF1> key
 ;;^UTILITY(U,$J,.84,9201,2,99,0)
 ;;=     followed by the letter 'B'.
 ;;^UTILITY(U,$J,.84,9201,2,100,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,101,0)
 ;;=     To GOTO a specific screen, line or column press the <PF1> key
 ;;^UTILITY(U,$J,.84,9201,2,102,0)
 ;;=     followed by the letter 'G'.  This will cause a prompt to be displayed
 ;;^UTILITY(U,$J,.84,9201,2,103,0)
 ;;=     where a screen, line or column number can be entered preceded by a
 ;;^UTILITY(U,$J,.84,9201,2,104,0)
 ;;=     'S' , 'L' or 'C'.  The default is screen, meaning that the 'S' is
 ;;^UTILITY(U,$J,.84,9201,2,105,0)
 ;;=     optional when entering a screen number.  10 or S10 will go to screen
 ;;^UTILITY(U,$J,.84,9201,2,106,0)
 ;;=     10, if screen 10 is a valid screen.  L99 will go to line 99 and C33
 ;;^UTILITY(U,$J,.84,9201,2,107,0)
 ;;=     will go to column 33.
 ;;^UTILITY(U,$J,.84,9201,2,108,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,109,0)
 ;;=     To FIND a string of characters, on a line, press the <PF1> key
 ;;^UTILITY(U,$J,.84,9201,2,110,0)
 ;;=     followed by the letter 'F' or 'FIND' key.  A prompt will appear where
 ;;^UTILITY(U,$J,.84,9201,2,111,0)
 ;;=     a search string of characters can be entered.  The Find facility will
 ;;^UTILITY(U,$J,.84,9201,2,112,0)
 ;;=     search the document and immediately stop when it finds a match and
 ;;^UTILITY(U,$J,.84,9201,2,113,0)
 ;;=     'Goto' the line/screen.  The matched text will be highlighted in
 ;;^UTILITY(U,$J,.84,9201,2,114,0)
 ;;=     reverse video, if available, so it can be found easily.  However, if
 ;;^UTILITY(U,$J,.84,9201,2,115,0)
 ;;=     a string contains two or more words, matching will only be done if
 ;;^UTILITY(U,$J,.84,9201,2,116,0)
 ;;=     the words are found on the same line.  The default direction of the
 ;;^UTILITY(U,$J,.84,9201,2,117,0)
 ;;=     search is down.  This can be controlled by using the ARROW UP or
 ;;^UTILITY(U,$J,.84,9201,2,118,0)
 ;;=     ARROW DOWN keys instead of the RETURN key to terminate the search
 ;;^UTILITY(U,$J,.84,9201,2,119,0)
 ;;=     string.
 ;;^UTILITY(U,$J,.84,9201,2,120,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,121,0)
 ;;=     To, NEXT FIND, find the next occurrence of the same search string,
 ;;^UTILITY(U,$J,.84,9201,2,122,0)
 ;;=     press the letter 'N' or <PF1> followed by the letter 'N'. The FIND

DINIT00W
DINIT00W ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9201,2,123,0)
 ;;=     facility keeps track of the last find string including the direction
 ;;^UTILITY(U,$J,.84,9201,2,124,0)
 ;;=     and continues searching through the document and brings up the next
 ;;^UTILITY(U,$J,.84,9201,2,125,0)
 ;;=     screen.  If no match is found a message appears indicating this and
 ;;^UTILITY(U,$J,.84,9201,2,126,0)
 ;;=     the screen is repainted at it's original location.
 ;;^UTILITY(U,$J,.84,9201,2,127,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,128,0)
 ;;=     To rePAINT the screen, press the <PF1> key followed by the letter
 ;;^UTILITY(U,$J,.84,9201,2,129,0)
 ;;=     'P'.
 ;;^UTILITY(U,$J,.84,9201,2,130,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,131,0)
 ;;=     To SWITCH to another document press the <PF1> key followed by the
 ;;^UTILITY(U,$J,.84,9201,2,132,0)
 ;;=     letter 'S'.  This will allow the selection of another file, (wp)field
 ;;^UTILITY(U,$J,.84,9201,2,133,0)
 ;;=     and entry.  The document is put on an active list and Browse
 ;;^UTILITY(U,$J,.84,9201,2,134,0)
 ;;=     switches to the newly selected document.  Subsequent use of Switch
 ;;^UTILITY(U,$J,.84,9201,2,135,0)
 ;;=     will allow choosing from the active list if desired or branch to
 ;;^UTILITY(U,$J,.84,9201,2,136,0)
 ;;=     select file, (wp)field and entry prompts. This function CAN BE
 ;;^UTILITY(U,$J,.84,9201,2,137,0)
 ;;=     RESTRICTED depending on how the running application calls the Browser
 ;;^UTILITY(U,$J,.84,9201,2,138,0)
 ;;=     utility.
 ;;^UTILITY(U,$J,.84,9201,2,139,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,140,0)
 ;;=     To RETURN to the previous document after using Switch or Help, press
 ;;^UTILITY(U,$J,.84,9201,2,141,0)
 ;;=     'R'.  A separate list keeps track of the documents chosen during the
 ;;^UTILITY(U,$J,.84,9201,2,142,0)
 ;;=     current Browse session.  R will return all the way back to the very
 ;;^UTILITY(U,$J,.84,9201,2,143,0)
 ;;=     first document when used repeatedly.
 ;;^UTILITY(U,$J,.84,9201,2,144,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,145,0)
 ;;=     To SPLIT SCREEN, while in Full (Browse Region) Screen mode, press
 ;;^UTILITY(U,$J,.84,9201,2,146,0)
 ;;=     <PF2> followed by the letter 'S'.  This causes the screen to split
 ;;^UTILITY(U,$J,.84,9201,2,147,0)
 ;;=     into two separate scroll regions.
 ;;^UTILITY(U,$J,.84,9201,2,148,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,149,0)
 ;;=     To navigate to the bottom screen, while in Split Screen mode, press
 ;;^UTILITY(U,$J,.84,9201,2,150,0)
 ;;=     <PF2> followed by pressing the ARROW DOWN key.
 ;;^UTILITY(U,$J,.84,9201,2,151,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,152,0)
 ;;=     To navigate to the top screen, while in Split Screen mode, press
 ;;^UTILITY(U,$J,.84,9201,2,153,0)
 ;;=     <PF2> followed by pressing the ARROW UP key.
 ;;^UTILITY(U,$J,.84,9201,2,154,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,155,0)
 ;;=     To return to FULL SCREEN mode, while in Split Screen mode, press
 ;;^UTILITY(U,$J,.84,9201,2,156,0)
 ;;=     <PF2> followed by the letter 'F'.  This causes the entire browse
 ;;^UTILITY(U,$J,.84,9201,2,157,0)
 ;;=     region to return to one Full (Browse) Screen scroll region.
 ;;^UTILITY(U,$J,.84,9201,2,158,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,159,0)
 ;;=     To RESIZE screens, while in Split Screen mode, press <PF2><PF2>
 ;;^UTILITY(U,$J,.84,9201,2,160,0)
 ;;=     followed by the ARROW UP key.  This makes the top window smaller and
 ;;^UTILITY(U,$J,.84,9201,2,161,0)
 ;;=     the bottom window larger.  <PF2><PF2> followed by the ARROW DOWN key
 ;;^UTILITY(U,$J,.84,9201,2,162,0)
 ;;=     makes the top window larger and the bottom window smaller.
 ;;^UTILITY(U,$J,.84,9201,2,163,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,164,0)
 ;;=     The TITLE BAR, at the top, is a non scrolling region which contains
 ;;^UTILITY(U,$J,.84,9201,2,165,0)
 ;;=     static information, while browsing in the selected document.  The
 ;;^UTILITY(U,$J,.84,9201,2,166,0)
 ;;=     title bar information only changes when switching documents or
 ;;^UTILITY(U,$J,.84,9201,2,167,0)
 ;;=     requesting help.
 ;;^UTILITY(U,$J,.84,9201,2,168,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,169,0)
 ;;=     The STATUS BAR, at the bottom, is also a non scroll region.  It shows
 ;;^UTILITY(U,$J,.84,9201,2,170,0)
 ;;=     the column indicator, how to get help, how to exit, line information

DINIT00X
DINIT00X ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9201,2,171,0)
 ;;=     and screen information.  The "Col>" indicates the column number the
 ;;^UTILITY(U,$J,.84,9201,2,172,0)
 ;;=     left edge of the browse window is over in the document.  The "Line>"
 ;;^UTILITY(U,$J,.84,9201,2,173,0)
 ;;=     shows the current line at the bottom of the scroll region and the
 ;;^UTILITY(U,$J,.84,9201,2,174,0)
 ;;=     total number of lines in the document.  The "Screen>" shows the
 ;;^UTILITY(U,$J,.84,9201,2,175,0)
 ;;=     current screen and the total number of screens in the document.
 ;;^UTILITY(U,$J,.84,9201,2,176,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,177,0)
 ;;=     The SCROLLING REGION, between the TITLE BAR and the STATUS BAR, is
 ;;^UTILITY(U,$J,.84,9201,2,178,0)
 ;;=     where the Browser displays the text being viewed.
 ;;^UTILITY(U,$J,.84,9201,2,179,0)
 ;;=     
 ;;^UTILITY(U,$J,.84,9201,2,180,0)
 ;;=     <<<Press 'R' or <PF1>'E' to exit this help document>>>
 ;;^UTILITY(U,$J,.84,9201,5,0)
 ;;=^.841^^0
 ;;^UTILITY(U,$J,.84,9211,0)
 ;;=9211^3^^11
 ;;^UTILITY(U,$J,.84,9211,1,0)
 ;;=^^1^1^2940624^^^^
 ;;^UTILITY(U,$J,.84,9211,1,1,0)
 ;;=Screen 1 of Screen Editor help.
 ;;^UTILITY(U,$J,.84,9211,2,0)
 ;;=^^17^17^2940830^
 ;;^UTILITY(U,$J,.84,9211,2,1,0)
 ;;=                                                           \BHelp Screen 1 of 4\n
 ;;^UTILITY(U,$J,.84,9211,2,2,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9211,2,3,0)
 ;;=\BSUMMARY OF KEY SEQUENCES\n
 ;;^UTILITY(U,$J,.84,9211,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9211,2,5,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9211,2,6,0)
 ;;=\BNavigation\n
 ;;^UTILITY(U,$J,.84,9211,2,7,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9211,2,8,0)
 ;;=   Incremental movement            Arrow keys
 ;;^UTILITY(U,$J,.84,9211,2,9,0)
 ;;=   One word left and right         <Ctrl-J> and <Ctrl-L>
 ;;^UTILITY(U,$J,.84,9211,2,10,0)
 ;;=   Next tab stop to the right      <Tab>
 ;;^UTILITY(U,$J,.84,9211,2,11,0)
 ;;=   Jump left and right             <PF1><Left> and <PF1><Right>
 ;;^UTILITY(U,$J,.84,9211,2,12,0)
 ;;=   Beginning and end of line       <PF1><PF1><Left> and <PF1><PF1><Right>
 ;;^UTILITY(U,$J,.84,9211,2,13,0)
 ;;=   Screen up or down               <PF1><Up> and <PF1><Down>
 ;;^UTILITY(U,$J,.84,9211,2,14,0)
 ;;=                                      or:  <PrevScr> and <NextScr>
 ;;^UTILITY(U,$J,.84,9211,2,15,0)
 ;;=                                      or:  <PageUp>  and <PageDown>
 ;;^UTILITY(U,$J,.84,9211,2,16,0)
 ;;=   Top or bottom of document       <PF1>T and <PF1>B
 ;;^UTILITY(U,$J,.84,9211,2,17,0)
 ;;=   Go to a specific location       <PF1>G
 ;;^UTILITY(U,$J,.84,9212,0)
 ;;=9212^3^^11
 ;;^UTILITY(U,$J,.84,9212,1,0)
 ;;=^^1^1^2940624^^^^
 ;;^UTILITY(U,$J,.84,9212,1,1,0)
 ;;=Screen 2 of Screen Editor help.
 ;;^UTILITY(U,$J,.84,9212,2,0)
 ;;=^^17^17^2940830^
 ;;^UTILITY(U,$J,.84,9212,2,1,0)
 ;;=                                                           \BHelp Screen 2 of 4\n
 ;;^UTILITY(U,$J,.84,9212,2,2,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9212,2,3,0)
 ;;=\BExiting/Saving\n
 ;;^UTILITY(U,$J,.84,9212,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9212,2,5,0)
 ;;=   Exit and save text              <PF1>E
 ;;^UTILITY(U,$J,.84,9212,2,6,0)
 ;;=   Quit without saving             <PF1>Q
 ;;^UTILITY(U,$J,.84,9212,2,7,0)
 ;;=   Exit, save, and switch editors  <PF1>A
 ;;^UTILITY(U,$J,.84,9212,2,8,0)
 ;;=   Save without exiting            <PF1>S
 ;;^UTILITY(U,$J,.84,9212,2,9,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9212,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9212,2,11,0)
 ;;=\BDeleting\n
 ;;^UTILITY(U,$J,.84,9212,2,12,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9212,2,13,0)
 ;;=   Character before cursor         <Backspace>
 ;;^UTILITY(U,$J,.84,9212,2,14,0)
 ;;=   Character at cursor             <PF4>  or  <Remove>  or  <Delete>
 ;;^UTILITY(U,$J,.84,9212,2,15,0)
 ;;=   From cursor to end of word      <Ctrl-W>
 ;;^UTILITY(U,$J,.84,9212,2,16,0)
 ;;=   From cursor to end of line      <PF1><PF2>
 ;;^UTILITY(U,$J,.84,9212,2,17,0)
 ;;=   Entire line                     <PF1>D
 ;;^UTILITY(U,$J,.84,9213,0)
 ;;=9213^3^^11
 ;;^UTILITY(U,$J,.84,9213,1,0)
 ;;=^^1^1^2940624^^^^
 ;;^UTILITY(U,$J,.84,9213,1,1,0)
 ;;=Screen 3 of Screen Editor help.
 ;;^UTILITY(U,$J,.84,9213,2,0)
 ;;=^^15^15^2940830^
 ;;^UTILITY(U,$J,.84,9213,2,1,0)
 ;;=                                                           \BHelp Screen 3 of 4\n
 ;;^UTILITY(U,$J,.84,9213,2,2,0)
 ;;=\BSettings/Modes\n
 ;;^UTILITY(U,$J,.84,9213,2,3,0)
 ;;= 

DINIT00Y
DINIT00Y ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9213,2,4,0)
 ;;=   Wrap/nowrap mode toggle         <PF2>
 ;;^UTILITY(U,$J,.84,9213,2,5,0)
 ;;=   Insert/replace mode toggle      <PF3>
 ;;^UTILITY(U,$J,.84,9213,2,6,0)
 ;;=   Set/clear tab stop              <PF1><Tab>
 ;;^UTILITY(U,$J,.84,9213,2,7,0)
 ;;=   Set left margin                 <PF1>,
 ;;^UTILITY(U,$J,.84,9213,2,8,0)
 ;;=   Set right margin                <PF1>.
 ;;^UTILITY(U,$J,.84,9213,2,9,0)
 ;;=   Status line toggle              <PF1>?
 ;;^UTILITY(U,$J,.84,9213,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9213,2,11,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9213,2,12,0)
 ;;=\BFormatting\n
 ;;^UTILITY(U,$J,.84,9213,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9213,2,14,0)
 ;;=   Join current line to next line  <PF1>J
 ;;^UTILITY(U,$J,.84,9213,2,15,0)
 ;;=   Reformat paragraph              <PF1>R
 ;;^UTILITY(U,$J,.84,9214,0)
 ;;=9214^3^^11
 ;;^UTILITY(U,$J,.84,9214,1,0)
 ;;=^^1^1^2940624^^^^
 ;;^UTILITY(U,$J,.84,9214,1,1,0)
 ;;=Screen 4 of Screen Editor help.
 ;;^UTILITY(U,$J,.84,9214,2,0)
 ;;=^^19^19^2940830^^^
 ;;^UTILITY(U,$J,.84,9214,2,1,0)
 ;;=                                                           \BHelp Screen 4 of 4\n
 ;;^UTILITY(U,$J,.84,9214,2,2,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9214,2,3,0)
 ;;=\BFinding\n
 ;;^UTILITY(U,$J,.84,9214,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9214,2,5,0)
 ;;=   Find text                       <PF1>F  or  <Find>
 ;;^UTILITY(U,$J,.84,9214,2,6,0)
 ;;=   Find next occurence of text     <PF1>N
 ;;^UTILITY(U,$J,.84,9214,2,7,0)
 ;;=   Find/RePlace text               <PF1>P
 ;;^UTILITY(U,$J,.84,9214,2,8,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9214,2,9,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9214,2,10,0)
 ;;=\BCutting/Copying/Pasting\n
 ;;^UTILITY(U,$J,.84,9214,2,11,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9214,2,12,0)
 ;;=   Select (Mark) text              <PF1>M at beginning and end of text
 ;;^UTILITY(U,$J,.84,9214,2,13,0)
 ;;=   Unselect (Unmark) text          <PF1><PF1>M
 ;;^UTILITY(U,$J,.84,9214,2,14,0)
 ;;=   Delete selected text            <Delete>  or  <Backspace> on selected text
 ;;^UTILITY(U,$J,.84,9214,2,15,0)
 ;;=   Cut and save to buffer          <PF1>X on selected text
 ;;^UTILITY(U,$J,.84,9214,2,16,0)
 ;;=   Copy and save to buffer         <PF1>C on selected text
 ;;^UTILITY(U,$J,.84,9214,2,17,0)
 ;;=   Paste from buffer               <PF1>V
 ;;^UTILITY(U,$J,.84,9214,2,18,0)
 ;;=   Move text to another location   <PF1>X at new location
 ;;^UTILITY(U,$J,.84,9214,2,19,0)
 ;;=   Copy text to another location   <PF1>C at new location
 ;;^UTILITY(U,$J,.84,9231,0)
 ;;=9231^3^^11
 ;;^UTILITY(U,$J,.84,9231,1,0)
 ;;=^^1^1^2940706^^
 ;;^UTILITY(U,$J,.84,9231,1,1,0)
 ;;=Screen 1 of ScreenMan help.
 ;;^UTILITY(U,$J,.84,9231,2,0)
 ;;=^^18^18^2940831^
 ;;^UTILITY(U,$J,.84,9231,2,1,0)
 ;;=                                                                \BScreen 1 of 3\n
 ;;^UTILITY(U,$J,.84,9231,2,2,0)
 ;;=                               \BSCREENMAN HELP\n
 ;;^UTILITY(U,$J,.84,9231,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9231,2,4,0)
 ;;=\BCursor Movement\n
 ;;^UTILITY(U,$J,.84,9231,2,5,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9231,2,6,0)
 ;;=Move right one character            <Right>
 ;;^UTILITY(U,$J,.84,9231,2,7,0)
 ;;=Move left one character             <Left>
 ;;^UTILITY(U,$J,.84,9231,2,8,0)
 ;;=Move right one word                 <Ctrl-L> or <PF1><Space>
 ;;^UTILITY(U,$J,.84,9231,2,9,0)
 ;;=Move left one word                  <Ctrl-J>
 ;;^UTILITY(U,$J,.84,9231,2,10,0)
 ;;=Move to right of window             <PF1><Right>
 ;;^UTILITY(U,$J,.84,9231,2,11,0)
 ;;=Move to left of window              <PF1><Left>
 ;;^UTILITY(U,$J,.84,9231,2,12,0)
 ;;=Move to end of field                <PF1><PF1><Right>
 ;;^UTILITY(U,$J,.84,9231,2,13,0)
 ;;=Move to beginning of field          <PF1><PF1><Left>
 ;;^UTILITY(U,$J,.84,9231,2,14,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9231,2,15,0)
 ;;=\BModes\n
 ;;^UTILITY(U,$J,.84,9231,2,16,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9231,2,17,0)
 ;;=Insert/Replace toggle               <PF3>
 ;;^UTILITY(U,$J,.84,9231,2,18,0)
 ;;=Zoom (invoke multiline editor)      <PF1>Z
 ;;^UTILITY(U,$J,.84,9232,0)
 ;;=9232^3^^11
 ;;^UTILITY(U,$J,.84,9232,1,0)
 ;;=^^1^1^2940706^
 ;;^UTILITY(U,$J,.84,9232,1,1,0)
 ;;=Screen 2 of ScreenMan help.
 ;;^UTILITY(U,$J,.84,9232,2,0)
 ;;=^^20^20^2940831^
 ;;^UTILITY(U,$J,.84,9232,2,1,0)
 ;;=                                                                \BScreen 2 of 3\n
 ;;^UTILITY(U,$J,.84,9232,2,2,0)
 ;;= 

DINIT00Z
DINIT00Z ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9232,2,3,0)
 ;;=\BDeletions\n
 ;;^UTILITY(U,$J,.84,9232,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9232,2,5,0)
 ;;=Character under cursor           <PF2> or <Delete>
 ;;^UTILITY(U,$J,.84,9232,2,6,0)
 ;;=Character left of cursor         <Backspace>
 ;;^UTILITY(U,$J,.84,9232,2,7,0)
 ;;=From cursor to end of word       <Ctrl-W>
 ;;^UTILITY(U,$J,.84,9232,2,8,0)
 ;;=From cursor to end of field      <PF1><PF2>
 ;;^UTILITY(U,$J,.84,9232,2,9,0)
 ;;=Toggle null/last edit/default    <PF1>D or <Ctrl-U>
 ;;^UTILITY(U,$J,.84,9232,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9232,2,11,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9232,2,12,0)
 ;;=\BMacro Movement\n
 ;;^UTILITY(U,$J,.84,9232,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9232,2,14,0)
 ;;=Field below         <Down>    |   Next page           <PF1><Down> or <PageDown>
 ;;^UTILITY(U,$J,.84,9232,2,15,0)
 ;;=Field above         <Up>      |   Previous page       <PF1><Up> or <PageUp>
 ;;^UTILITY(U,$J,.84,9232,2,16,0)
 ;;=Field to right      <Tab>     |   Next block          <PF1><PF4>
 ;;^UTILITY(U,$J,.84,9232,2,17,0)
 ;;=Field to left       <PF4>     |   Jump to a field     ^caption
 ;;^UTILITY(U,$J,.84,9232,2,18,0)
 ;;=Pre-defined order   <Return>  |   Go to Command Line  ^
 ;;^UTILITY(U,$J,.84,9232,2,19,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9232,2,20,0)
 ;;=Go into multiple or word processing field             <Return>
 ;;^UTILITY(U,$J,.84,9233,0)
 ;;=9233^3^^11
 ;;^UTILITY(U,$J,.84,9233,1,0)
 ;;=^^1^1^2941116^^
 ;;^UTILITY(U,$J,.84,9233,1,1,0)
 ;;=Screen 3 of ScreenMan help.
 ;;^UTILITY(U,$J,.84,9233,2,0)
 ;;=^^18^18^2941116^
 ;;^UTILITY(U,$J,.84,9233,2,1,0)
 ;;=                                                                \BScreen 3 of 3\n
 ;;^UTILITY(U,$J,.84,9233,2,2,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9233,2,3,0)
 ;;=\BCommand Line Options\n (Enter '^' at any field to jump to the command line.)
 ;;^UTILITY(U,$J,.84,9233,2,4,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9233,2,5,0)
 ;;=Command      Shortcut      Description
 ;;^UTILITY(U,$J,.84,9233,2,6,0)
 ;;=-------      --------      -----------
 ;;^UTILITY(U,$J,.84,9233,2,7,0)
 ;;=EXIT         see below     Exit form (asks whether changes should be saved)
 ;;^UTILITY(U,$J,.84,9233,2,8,0)
 ;;=CLOSE        <PF1>C        Close window and return to previous level
 ;;^UTILITY(U,$J,.84,9233,2,9,0)
 ;;=SAVE         <PF1>S        Save changes
 ;;^UTILITY(U,$J,.84,9233,2,10,0)
 ;;=NEXT PAGE    <PF1><Down>   Go to next page
 ;;^UTILITY(U,$J,.84,9233,2,11,0)
 ;;=REFRESH      <PF1>R        Repaint screen
 ;;^UTILITY(U,$J,.84,9233,2,12,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9233,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9233,2,14,0)
 ;;=\BOther Shortcut Keys\n
 ;;^UTILITY(U,$J,.84,9233,2,15,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9233,2,16,0)
 ;;=Exit form and save changes             <PF1>E
 ;;^UTILITY(U,$J,.84,9233,2,17,0)
 ;;=Quit form without saving changes       <PF1>Q
 ;;^UTILITY(U,$J,.84,9233,2,18,0)
 ;;=Invoke Record Selection Page           <PF1>L
 ;;^UTILITY(U,$J,.84,9251,0)
 ;;=9251^3^^11
 ;;^UTILITY(U,$J,.84,9251,1,0)
 ;;=^^1^1^2940707^^
 ;;^UTILITY(U,$J,.84,9251,1,1,0)
 ;;=Help Screen 1 of Form Editor help.
 ;;^UTILITY(U,$J,.84,9251,2,0)
 ;;=^^22^22^2940707^
 ;;^UTILITY(U,$J,.84,9251,2,1,0)
 ;;=                                                          \BHelp Screen 1 of 9\n
 ;;^UTILITY(U,$J,.84,9251,2,2,0)
 ;;=\BNAVIGATIONAL KEYS\n
 ;;^UTILITY(U,$J,.84,9251,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9251,2,4,0)
 ;;=Press    To move              |  Press         To move
 ;;^UTILITY(U,$J,.84,9251,2,5,0)
 ;;=-------------------------------------------------------------------
 ;;^UTILITY(U,$J,.84,9251,2,6,0)
 ;;=<Up>     Up one line          |  <PF1><Up>     To top of screen
 ;;^UTILITY(U,$J,.84,9251,2,7,0)
 ;;=<Down>   Down one line        |  <PF1><Down>   To bottom of screen
 ;;^UTILITY(U,$J,.84,9251,2,8,0)
 ;;=<Right>  Right one character  |  <PF1><Right>  To right edge of screen
 ;;^UTILITY(U,$J,.84,9251,2,9,0)
 ;;=<Left>   Left one character   |  <PF1><Left>   To left edge of screen
 ;;^UTILITY(U,$J,.84,9251,2,10,0)
 ;;=<Tab>    To next element
 ;;^UTILITY(U,$J,.84,9251,2,11,0)
 ;;=Q        To previous element
 ;;^UTILITY(U,$J,.84,9251,2,12,0)
 ;;=S        Right 5 characters
 ;;^UTILITY(U,$J,.84,9251,2,13,0)
 ;;=A        Left 5 characters
 ;;^UTILITY(U,$J,.84,9251,2,14,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9251,2,15,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9251,2,16,0)
 ;;=\BSAVING AND EXITING\n

DINIT010
DINIT010 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9251,2,17,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9251,2,18,0)
 ;;=Press    To
 ;;^UTILITY(U,$J,.84,9251,2,19,0)
 ;;=----------------------------------------------------
 ;;^UTILITY(U,$J,.84,9251,2,20,0)
 ;;=<PF1>S   Save changes
 ;;^UTILITY(U,$J,.84,9251,2,21,0)
 ;;=<PF1>E   Save changes and exit the Form Editor
 ;;^UTILITY(U,$J,.84,9251,2,22,0)
 ;;=<PF1>Q   Quit the Form Editor without saving changes
 ;;^UTILITY(U,$J,.84,9252,0)
 ;;=9252^3^^11
 ;;^UTILITY(U,$J,.84,9252,1,0)
 ;;=^^1^1^2941116^^^
 ;;^UTILITY(U,$J,.84,9252,1,1,0)
 ;;=Help Screen 2 of Form Editor.
 ;;^UTILITY(U,$J,.84,9252,2,0)
 ;;=^^19^19^2941116^
 ;;^UTILITY(U,$J,.84,9252,2,1,0)
 ;;=                                                          \BHelp Screen 2 of 9\n
 ;;^UTILITY(U,$J,.84,9252,2,2,0)
 ;;=\BSELECTING SCREEN ELEMENTS\n
 ;;^UTILITY(U,$J,.84,9252,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9252,2,4,0)
 ;;=To "select" a screen element, position the cursor over the element and
 ;;^UTILITY(U,$J,.84,9252,2,5,0)
 ;;=press <SpaceBar> or <Enter>.  This process is abbreviated <SelectElement>.
 ;;^UTILITY(U,$J,.84,9252,2,6,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9252,2,7,0)
 ;;=Press            To
 ;;^UTILITY(U,$J,.84,9252,2,8,0)
 ;;=----------------------------------------
 ;;^UTILITY(U,$J,.84,9252,2,9,0)
 ;;=<SelectElement>  Select a screen element
 ;;^UTILITY(U,$J,.84,9252,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9252,2,11,0)
 ;;=Once an element is selected, you can drag it around the screen by using
 ;;^UTILITY(U,$J,.84,9252,2,12,0)
 ;;=the navigational keys.  You cannot drag an element beyond the boundaries
 ;;^UTILITY(U,$J,.84,9252,2,13,0)
 ;;=of the block on which it is defined.
 ;;^UTILITY(U,$J,.84,9252,2,14,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9252,2,15,0)
 ;;=If you press <SpaceBar> or <Enter> over the caption of an element, both
 ;;^UTILITY(U,$J,.84,9252,2,16,0)
 ;;=the caption and data portion of the element, if one exists, are selected.
 ;;^UTILITY(U,$J,.84,9252,2,17,0)
 ;;=If you press <SpaceBar> or <Enter> over the data portion of an element,
 ;;^UTILITY(U,$J,.84,9252,2,18,0)
 ;;=only the data portion is selected and can be dragged independently of the
 ;;^UTILITY(U,$J,.84,9252,2,19,0)
 ;;=caption.  Press <SpaceBar> or <Enter> again to deselect the element.
 ;;^UTILITY(U,$J,.84,9253,0)
 ;;=9253^3^^11
 ;;^UTILITY(U,$J,.84,9253,1,0)
 ;;=^^1^1^2940707^
 ;;^UTILITY(U,$J,.84,9253,1,1,0)
 ;;=Help Screen 3 of Form Editor.
 ;;^UTILITY(U,$J,.84,9253,2,0)
 ;;=^^15^15^2940707^
 ;;^UTILITY(U,$J,.84,9253,2,1,0)
 ;;=                                                          \BHelp Screen 3 of 9\n
 ;;^UTILITY(U,$J,.84,9253,2,2,0)
 ;;=\BEDITING ELEMENT PROPERTIES\n
 ;;^UTILITY(U,$J,.84,9253,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9253,2,4,0)
 ;;=Press                 To
 ;;^UTILITY(U,$J,.84,9253,2,5,0)
 ;;=---------------------------------------------
 ;;^UTILITY(U,$J,.84,9253,2,6,0)
 ;;=<SelectElement><PF4>  Edit element properties
 ;;^UTILITY(U,$J,.84,9253,2,7,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9253,2,8,0)
 ;;=You will then be taken into a ScreenMan form where the properties of the
 ;;^UTILITY(U,$J,.84,9253,2,9,0)
 ;;=element can be edited.
 ;;^UTILITY(U,$J,.84,9253,2,10,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9253,2,11,0)
 ;;=The Form Editor uses ScreenMan forms as a kind of modal dialog box.  The
 ;;^UTILITY(U,$J,.84,9253,2,12,0)
 ;;=changes you make within the forms are permanent; that is, if from a
 ;;^UTILITY(U,$J,.84,9253,2,13,0)
 ;;=ScreenMan form you edit the properties of an element, use <PF1>E to save
 ;;^UTILITY(U,$J,.84,9253,2,14,0)
 ;;=and exit the form, and then use <PF1>Q to quit the Form Editor, the
 ;;^UTILITY(U,$J,.84,9253,2,15,0)
 ;;=changes you made to the properties of the element will remain.
 ;;^UTILITY(U,$J,.84,9254,0)
 ;;=9254^3^^11
 ;;^UTILITY(U,$J,.84,9254,1,0)
 ;;=^^1^1^2940707^
 ;;^UTILITY(U,$J,.84,9254,1,1,0)
 ;;=Help Screen 4 of Form Editor.
 ;;^UTILITY(U,$J,.84,9254,2,0)
 ;;=^^18^18^2940707^
 ;;^UTILITY(U,$J,.84,9254,2,1,0)
 ;;=                                                          \BHelp Screen 4 of 9\n
 ;;^UTILITY(U,$J,.84,9254,2,2,0)
 ;;=\BEDITING A CAPTION OR DATA LENGTH\n
 ;;^UTILITY(U,$J,.84,9254,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9254,2,4,0)
 ;;=To edit the caption or data length of an element from the Form Editor's
 ;;^UTILITY(U,$J,.84,9254,2,5,0)
 ;;=Main screen, you can position the cursor over the caption or data portion

DINIT011
DINIT011 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9254,2,6,0)
 ;;=of the element and press:
 ;;^UTILITY(U,$J,.84,9254,2,7,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9254,2,8,0)
 ;;=     <PF3>     Edit caption or data length
 ;;^UTILITY(U,$J,.84,9254,2,9,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9254,2,10,0)
 ;;=If you press <PF3> while the cursor is over a caption, you'll be taken
 ;;^UTILITY(U,$J,.84,9254,2,11,0)
 ;;=into a caption editor.  The editing keys available to you are identical
 ;;^UTILITY(U,$J,.84,9254,2,12,0)
 ;;=to those in ScreenMan's field editor.
 ;;^UTILITY(U,$J,.84,9254,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9254,2,14,0)
 ;;=If you press <PF3> while the cursor is over the data portion of an element,
 ;;^UTILITY(U,$J,.84,9254,2,15,0)
 ;;=you can then use the <Right> and <Left> arrow keys to increase and
 ;;^UTILITY(U,$J,.84,9254,2,16,0)
 ;;=decrease the data length.  An indicator at the lower right edge of the
 ;;^UTILITY(U,$J,.84,9254,2,17,0)
 ;;=screen indicates the current length of the data.  Press <Enter> to exit
 ;;^UTILITY(U,$J,.84,9254,2,18,0)
 ;;=the caption or data length editor.
 ;;^UTILITY(U,$J,.84,9255,0)
 ;;=9255^3^^11
 ;;^UTILITY(U,$J,.84,9255,1,0)
 ;;=^^1^1^2940707^
 ;;^UTILITY(U,$J,.84,9255,1,1,0)
 ;;=Help Screen 5 of Form Editor.
 ;;^UTILITY(U,$J,.84,9255,2,0)
 ;;=^^18^18^2940707^
 ;;^UTILITY(U,$J,.84,9255,2,1,0)
 ;;=                                                          \BHelp Screen 5 of 9\n
 ;;^UTILITY(U,$J,.84,9255,2,2,0)
 ;;=\BVIEWING THE BLOCKS ON A PAGE\n
 ;;^UTILITY(U,$J,.84,9255,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9255,2,4,0)
 ;;=The Form Editor's main screen displays the field elements on a page, but
 ;;^UTILITY(U,$J,.84,9255,2,5,0)
 ;;=does not display any information about the blocks on that page.  A Block
 ;;^UTILITY(U,$J,.84,9255,2,6,0)
 ;;=Viewer screen shows the blocks on a page.  From the Block Viewer screen
 ;;^UTILITY(U,$J,.84,9255,2,7,0)
 ;;=you can move entire blocks, and edit block properties.
 ;;^UTILITY(U,$J,.84,9255,2,8,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9255,2,9,0)
 ;;=Press    To
 ;;^UTILITY(U,$J,.84,9255,2,10,0)
 ;;=-----------------------------------------------------------
 ;;^UTILITY(U,$J,.84,9255,2,11,0)
 ;;=<PF1>V   Toggle between Block Viewer screen and Main screen
 ;;^UTILITY(U,$J,.84,9255,2,12,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9255,2,13,0)
 ;;=The Block Viewer screen displays the names of the blocks on the current
 ;;^UTILITY(U,$J,.84,9255,2,14,0)
 ;;=page.  From this screen, you can select blocks and edit their properties.
 ;;^UTILITY(U,$J,.84,9255,2,15,0)
 ;;=To return to the Form Editor's main screen, press <PF1>V, <PF1>E, or <PF1>Q.
 ;;^UTILITY(U,$J,.84,9255,2,16,0)
 ;;=If two blocks have the some coordinates, the block names will overlap on
 ;;^UTILITY(U,$J,.84,9255,2,17,0)
 ;;=the Block Viewer screen.  Also, since header blocks have a fixed position
 ;;^UTILITY(U,$J,.84,9255,2,18,0)
 ;;=of (1,1) relative to the page, they cannot be moved.
 ;;^UTILITY(U,$J,.84,9256,0)
 ;;=9256^3^^11
 ;;^UTILITY(U,$J,.84,9256,1,0)
 ;;=^^1^1^2940707^
 ;;^UTILITY(U,$J,.84,9256,1,1,0)
 ;;=Help Screen 6 of Form Editor.
 ;;^UTILITY(U,$J,.84,9256,2,0)
 ;;=^^10^10^2940707^
 ;;^UTILITY(U,$J,.84,9256,2,1,0)
 ;;=                                                          \BHelp Screen 6 of 9\n
 ;;^UTILITY(U,$J,.84,9256,2,2,0)
 ;;=\BPAGE NAVIGATION\n
 ;;^UTILITY(U,$J,.84,9256,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9256,2,4,0)
 ;;=Press             To move to
 ;;^UTILITY(U,$J,.84,9256,2,5,0)
 ;;=----------------------------------------------------------
 ;;^UTILITY(U,$J,.84,9256,2,6,0)
 ;;=<PF1><PF1><Up>    Previous page
 ;;^UTILITY(U,$J,.84,9256,2,7,0)
 ;;=<PF1><PF1><Down>  Next page
 ;;^UTILITY(U,$J,.84,9256,2,8,0)
 ;;=<SelectElement>D  Subpage associated with selected element
 ;;^UTILITY(U,$J,.84,9256,2,9,0)
 ;;=<PF1>C            Parent page (Close current pop-up page)
 ;;^UTILITY(U,$J,.84,9256,2,10,0)
 ;;=<PF1>P            A specific page (you are prompted for the page)
 ;;^UTILITY(U,$J,.84,9257,0)
 ;;=9257^3^^11
 ;;^UTILITY(U,$J,.84,9257,1,0)
 ;;=^^1^1^2940725^^
 ;;^UTILITY(U,$J,.84,9257,1,1,0)
 ;;=Help Screen 7 of Form Editor.
 ;;^UTILITY(U,$J,.84,9257,2,0)
 ;;=^^15^15^2940725^
 ;;^UTILITY(U,$J,.84,9257,2,1,0)
 ;;=                                                          \BHelp Screen 7 of 9\n
 ;;^UTILITY(U,$J,.84,9257,2,2,0)
 ;;=\BSELECTING, ADDING, AND EDITING FORM ELEMENTS\n
 ;;^UTILITY(U,$J,.84,9257,2,3,0)
 ;;= 

DINIT012
DINIT012 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9257,2,4,0)
 ;;=Press   To
 ;;^UTILITY(U,$J,.84,9257,2,5,0)
 ;;=----------------------------------------
 ;;^UTILITY(U,$J,.84,9257,2,6,0)
 ;;=<PF1>M  Select another form
 ;;^UTILITY(U,$J,.84,9257,2,7,0)
 ;;=<PF1>P  Select another page
 ;;^UTILITY(U,$J,.84,9257,2,8,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9257,2,9,0)
 ;;=<PF2>M  Add a new form
 ;;^UTILITY(U,$J,.84,9257,2,10,0)
 ;;=<PF2>P  Add a new page
 ;;^UTILITY(U,$J,.84,9257,2,11,0)
 ;;=<PF2>B  Add a new block
 ;;^UTILITY(U,$J,.84,9257,2,12,0)
 ;;=<PF2>F  Add a new field element
 ;;^UTILITY(U,$J,.84,9257,2,13,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9257,2,14,0)
 ;;=<PF4>M  Edit properties of current form
 ;;^UTILITY(U,$J,.84,9257,2,15,0)
 ;;=<PF4>P  Edit properties of current page
 ;;^UTILITY(U,$J,.84,9258,0)
 ;;=9258^3^^11
 ;;^UTILITY(U,$J,.84,9258,1,0)
 ;;=^^1^1^2940707^
 ;;^UTILITY(U,$J,.84,9258,1,1,0)
 ;;=Help Screen 8 of Form Editor.
 ;;^UTILITY(U,$J,.84,9258,2,0)
 ;;=^^11^11^2940707^
 ;;^UTILITY(U,$J,.84,9258,2,1,0)
 ;;=                                                          \BHelp Screen 8 of 9\n
 ;;^UTILITY(U,$J,.84,9258,2,2,0)
 ;;=\BDELETING ELEMENTS\n
 ;;^UTILITY(U,$J,.84,9258,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9258,2,4,0)
 ;;=To delete an element, edit the properties of the element, and enter an
 ;;^UTILITY(U,$J,.84,9258,2,5,0)
 ;;=at-sign (@) at the first field of the ScreenMan form.  For example, to
 ;;^UTILITY(U,$J,.84,9258,2,6,0)
 ;;=delete a field from a block, select the field with <SpaceBar>, press <PF4>
 ;;^UTILITY(U,$J,.84,9258,2,7,0)
 ;;=to invoke the "edit properties" form, and enter @ at the "Field Order:"
 ;;^UTILITY(U,$J,.84,9258,2,8,0)
 ;;=prompt.
 ;;^UTILITY(U,$J,.84,9258,2,9,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9258,2,10,0)
 ;;=You cannot use the Form Editor to delete entire forms or blocks.  A separate
 ;;^UTILITY(U,$J,.84,9258,2,11,0)
 ;;=utility provides that functionality.
 ;;^UTILITY(U,$J,.84,9259,0)
 ;;=9259^3^^11
 ;;^UTILITY(U,$J,.84,9259,1,0)
 ;;=^^1^1^2940707^^
 ;;^UTILITY(U,$J,.84,9259,1,1,0)
 ;;=Help Screen 9 of Form Editor.
 ;;^UTILITY(U,$J,.84,9259,2,0)
 ;;=^^16^16^2940707^
 ;;^UTILITY(U,$J,.84,9259,2,1,0)
 ;;=                                                          \BHelp Screen 9 of 9\n
 ;;^UTILITY(U,$J,.84,9259,2,2,0)
 ;;=\BREORDERING FIELDS ON A BLOCK\n
 ;;^UTILITY(U,$J,.84,9259,2,3,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9259,2,4,0)
 ;;=After creating and arranging all the elements on a block, you can quickly
 ;;^UTILITY(U,$J,.84,9259,2,5,0)
 ;;=make the field orders of all the elements equivalent to the tab order
 ;;^UTILITY(U,$J,.84,9259,2,6,0)
 ;;=by doing the following:
 ;;^UTILITY(U,$J,.84,9259,2,7,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9259,2,8,0)
 ;;=     1.  Go to the Block Viewer page (<PF1>V)
 ;;^UTILITY(U,$J,.84,9259,2,9,0)
 ;;=     2.  Select the block (<SpaceBar> over the block name)
 ;;^UTILITY(U,$J,.84,9259,2,10,0)
 ;;=     3.  Press <PF1>O
 ;;^UTILITY(U,$J,.84,9259,2,11,0)
 ;;= 
 ;;^UTILITY(U,$J,.84,9259,2,12,0)
 ;;=The field order is the order in which the elements on the block are
 ;;^UTILITY(U,$J,.84,9259,2,13,0)
 ;;=traversed when the user presses the <Enter> key.  The <PF1>O key
 ;;^UTILITY(U,$J,.84,9259,2,14,0)
 ;;=sequence reassigns field order numbers to all the elements on the
 ;;^UTILITY(U,$J,.84,9259,2,15,0)
 ;;=block, so that the <Enter> key takes the user from element to element
 ;;^UTILITY(U,$J,.84,9259,2,16,0)
 ;;=in the same order as the <Tab> key (left to right, top to bottom).
 ;;^UTILITY(U,$J,.84,9501,0)
 ;;=9501^1^^11
 ;;^UTILITY(U,$J,.84,9501,1,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9501,1,1,0)
 ;;=DIFROM Server, FIA array does not exist or invalid.
 ;;^UTILITY(U,$J,.84,9501,2,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9501,2,1,0)
 ;;=FIA array does not exist or invalid.
 ;;^UTILITY(U,$J,.84,9502,0)
 ;;=9502^1^^11
 ;;^UTILITY(U,$J,.84,9502,1,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9502,1,1,0)
 ;;=FIA file number invalid.
 ;;^UTILITY(U,$J,.84,9502,2,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9502,2,1,0)
 ;;=FIA file number invalid.
 ;;^UTILITY(U,$J,.84,9503,0)
 ;;=9503^1^^11
 ;;^UTILITY(U,$J,.84,9503,1,0)
 ;;=^^1^1^2940908^^^^
 ;;^UTILITY(U,$J,.84,9503,1,1,0)
 ;;=DIFROM Server; FIA node is set to "NO DD UPDATE"
 ;;^UTILITY(U,$J,.84,9503,2,0)
 ;;=^^1^1^2940908^^^^
 ;;^UTILITY(U,$J,.84,9503,2,1,0)
 ;;=Data Dictionary not installed; FIA node is set to "No DD Update"

DINIT013
DINIT013 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9504,0)
 ;;=9504^1^^11
 ;;^UTILITY(U,$J,.84,9504,1,0)
 ;;=^^1^1^2940908^^
 ;;^UTILITY(U,$J,.84,9504,1,1,0)
 ;;=DIFROM Server; Installing DD only if file is new on target system.
 ;;^UTILITY(U,$J,.84,9504,2,0)
 ;;=^^1^1^2940908^^
 ;;^UTILITY(U,$J,.84,9504,2,1,0)
 ;;=Data Dictionary not installed; DD already exist on target system.
 ;;^UTILITY(U,$J,.84,9505,0)
 ;;=9505^1^^11
 ;;^UTILITY(U,$J,.84,9505,1,0)
 ;;=^^1^1^2940915^^^
 ;;^UTILITY(U,$J,.84,9505,1,1,0)
 ;;=DIFROM Server; Did not pass DD screen.
 ;;^UTILITY(U,$J,.84,9505,2,0)
 ;;=^^1^1^2940915^^^
 ;;^UTILITY(U,$J,.84,9505,2,1,0)
 ;;=Data Dictionary not updated; Did not pass DD Screen.
 ;;^UTILITY(U,$J,.84,9506,0)
 ;;=9506^1^^11
 ;;^UTILITY(U,$J,.84,9506,1,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9506,1,1,0)
 ;;=DIFROM Server;  Transport structure does not exist or invalid.
 ;;^UTILITY(U,$J,.84,9506,2,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9506,2,1,0)
 ;;=Transport array does not exist or invalid.
 ;;^UTILITY(U,$J,.84,9507,0)
 ;;=9507^1^^11
 ;;^UTILITY(U,$J,.84,9507,1,0)
 ;;=^^1^1^2940908^^
 ;;^UTILITY(U,$J,.84,9507,1,1,0)
 ;;=DIFROM Server;  FIA file number invalid.
 ;;^UTILITY(U,$J,.84,9507,2,0)
 ;;=^^1^1^2940908^^
 ;;^UTILITY(U,$J,.84,9507,2,1,0)
 ;;=Data Dictionary not installed; FIA file number invalid.
 ;;^UTILITY(U,$J,.84,9508,0)
 ;;=9508^1^^11
 ;;^UTILITY(U,$J,.84,9508,1,0)
 ;;=^^1^1^2940908^^^
 ;;^UTILITY(U,$J,.84,9508,1,1,0)
 ;;=DIFROM Server;  File does not exist on target system (Partial DD).
 ;;^UTILITY(U,$J,.84,9508,2,0)
 ;;=^^1^1^2940908^^^
 ;;^UTILITY(U,$J,.84,9508,2,1,0)
 ;;=Data Dictionary not installed; Partial DD/File does not exist.
 ;;^UTILITY(U,$J,.84,9509,0)
 ;;=9509^1^^11
 ;;^UTILITY(U,$J,.84,9509,1,0)
 ;;=^^1^1^2940908^^^
 ;;^UTILITY(U,$J,.84,9509,1,1,0)
 ;;=DIFROMS Server;  FIA node is set to send "No Data"
 ;;^UTILITY(U,$J,.84,9509,2,0)
 ;;=^^1^1^2940908^^^
 ;;^UTILITY(U,$J,.84,9509,2,1,0)
 ;;=FIA array is set to "No data"
 ;;^UTILITY(U,$J,.84,9510,0)
 ;;=9510^1^^11
 ;;^UTILITY(U,$J,.84,9510,1,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9510,1,1,0)
 ;;=DIFROM Server;  Records to transport do not exist.
 ;;^UTILITY(U,$J,.84,9510,2,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9510,2,1,0)
 ;;=Records do not exist.
 ;;^UTILITY(U,$J,.84,9511,0)
 ;;=9511^1^^11
 ;;^UTILITY(U,$J,.84,9511,1,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9511,1,1,0)
 ;;=DIFROM Server; DD not installed because FIA array does not exist.
 ;;^UTILITY(U,$J,.84,9511,2,0)
 ;;=^^1^1^2940908^
 ;;^UTILITY(U,$J,.84,9511,2,1,0)
 ;;=Data Dictionary not installed; FIA array does not exist.
 ;;^UTILITY(U,$J,.84,9512,0)
 ;;=9512^1^y^11
 ;;^UTILITY(U,$J,.84,9512,1,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9512,1,1,0)
 ;;=Parent DD missing on Partial DD.
 ;;^UTILITY(U,$J,.84,9512,2,0)
 ;;=^^1^1^2940909^^^^
 ;;^UTILITY(U,$J,.84,9512,2,1,0)
 ;;=DD: |1| not installed, parent DD(s) missing.
 ;;^UTILITY(U,$J,.84,9513,0)
 ;;=9513^1^y^11
 ;;^UTILITY(U,$J,.84,9513,1,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9513,1,1,0)
 ;;=Invalid record in file.
 ;;^UTILITY(U,$J,.84,9513,2,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9513,2,1,0)
 ;;=IEN: |1| in file |2| is invalid.
 ;;^UTILITY(U,$J,.84,9514,0)
 ;;=9514^1^y^11
 ;;^UTILITY(U,$J,.84,9514,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9514,1,1,0)
 ;;=Dangling pointer.  File, IEN and field.
 ;;^UTILITY(U,$J,.84,9514,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9514,2,1,0)
 ;;=Dangling pointer.  FILE: |1|, IEN: |2| FIELD: |3|
 ;;^UTILITY(U,$J,.84,9515,0)
 ;;=9515^1^y^11
 ;;^UTILITY(U,$J,.84,9515,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9515,1,1,0)
 ;;=No sending data on partial DDs.
 ;;^UTILITY(U,$J,.84,9515,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9515,2,1,0)
 ;;=Partial DD.  No sending of data allowed for file |1|.
 ;;^UTILITY(U,$J,.84,9516,0)
 ;;=9516^1^y^11
 ;;^UTILITY(U,$J,.84,9516,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9516,1,1,0)
 ;;=Invalid entry in trasnport structure.
 ;;^UTILITY(U,$J,.84,9516,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9516,2,1,0)
 ;;=Transport structure does not contain |1| with IEN: |2|.
 ;;^UTILITY(U,$J,.84,9517,0)
 ;;=9517^1^y^11
 ;;^UTILITY(U,$J,.84,9517,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9517,1,1,0)
 ;;=DIFROM Server unable to install block.
 ;;^UTILITY(U,$J,.84,9517,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9517,2,1,0)
 ;;=DIFROM Server unable to install |1| block.

DINIT014
DINIT014 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9518,0)
 ;;=9518^1^y^11
 ;;^UTILITY(U,$J,.84,9518,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9518,1,1,0)
 ;;=DIFROM Server installed block but associated file not present.
 ;;^UTILITY(U,$J,.84,9518,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9518,2,1,0)
 ;;=|1| block installed but associated file #|2| is not on your system.
 ;;^UTILITY(U,$J,.84,9519,0)
 ;;=9519^1^^11
 ;;^UTILITY(U,$J,.84,9519,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9519,1,1,0)
 ;;=File number missing for "FILE-PRE" in KIDS process.
 ;;^UTILITY(U,$J,.84,9519,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9519,2,1,0)
 ;;=File number missing in "FILE-PRE".
 ;;^UTILITY(U,$J,.84,9520,0)
 ;;=9520^1^^11
 ;;^UTILITY(U,$J,.84,9520,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9520,1,1,0)
 ;;=Package name missing for "FILE-PRE" in KIDS process.
 ;;^UTILITY(U,$J,.84,9520,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9520,2,1,0)
 ;;=Package name missing for "FILE-PRE".
 ;;^UTILITY(U,$J,.84,9521,0)
 ;;=9521^1^^11
 ;;^UTILITY(U,$J,.84,9521,1,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9521,1,1,0)
 ;;=Invalid file number in KIDS "ENTRY-PRE"
 ;;^UTILITY(U,$J,.84,9521,2,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9521,2,1,0)
 ;;=File number invalid in "ENTRY-PRE".
 ;;^UTILITY(U,$J,.84,9522,0)
 ;;=9522^1^^11
 ;;^UTILITY(U,$J,.84,9522,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9522,1,1,0)
 ;;=Invalid entry number in KIDS "ENTRY-PRE"
 ;;^UTILITY(U,$J,.84,9522,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9522,2,1,0)
 ;;=Entry number invalid for "ENTRY-PRE"
 ;;^UTILITY(U,$J,.84,9523,0)
 ;;=9523^1^^11
 ;;^UTILITY(U,$J,.84,9523,1,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9523,1,1,0)
 ;;=Invalid entry in transport array.
 ;;^UTILITY(U,$J,.84,9523,2,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9523,2,1,0)
 ;;=Entry number invalid in transport array (source site DA).
 ;;^UTILITY(U,$J,.84,9524,0)
 ;;=9524^1^^11
 ;;^UTILITY(U,$J,.84,9524,1,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9524,1,1,0)
 ;;=Package name invalid in "ENTRY-PRE".
 ;;^UTILITY(U,$J,.84,9524,2,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9524,2,1,0)
 ;;=Invalid package name in "ENTRY-PRE".
 ;;^UTILITY(U,$J,.84,9525,0)
 ;;=9525^1^y^11
 ;;^UTILITY(U,$J,.84,9525,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9525,1,1,0)
 ;;=Package name ambigious.  Pointer not resolved.
 ;;^UTILITY(U,$J,.84,9525,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9525,2,1,0)
 ;;=|1| package name is ambigious.  Pointer |2| not resolved.
 ;;^UTILITY(U,$J,.84,9526,0)
 ;;=9526^1^^11
 ;;^UTILITY(U,$J,.84,9526,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9526,1,1,0)
 ;;=ZSave not defined in MUMPS Operating file.  Can not compile templates.
 ;;^UTILITY(U,$J,.84,9526,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9526,2,1,0)
 ;;=Unable to compile templates.  ZSave undefined in OS file.
 ;;^UTILITY(U,$J,.84,9527,0)
 ;;=9527^1^y^11
 ;;^UTILITY(U,$J,.84,9527,1,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9527,1,1,0)
 ;;=Invalid form.  DIFROM Server is unable to compile.
 ;;^UTILITY(U,$J,.84,9527,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9527,2,1,0)
 ;;=|1| form invalid.  Can not be compiled by KIDS process.
 ;;^UTILITY(U,$J,.84,9528,0)
 ;;=9528^1^y^11
 ;;^UTILITY(U,$J,.84,9528,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9528,1,1,0)
 ;;=Template can not be compiled.
 ;;^UTILITY(U,$J,.84,9528,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9528,2,1,0)
 ;;=|1| template |2| is invalid.  KIDS process can not compile.
 ;;^UTILITY(U,$J,.84,9529,0)
 ;;=9529^1^^11
 ;;^UTILITY(U,$J,.84,9529,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9529,1,1,0)
 ;;=Template or form file number is invalid.  DIFROM Server/KIDS
 ;;^UTILITY(U,$J,.84,9529,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9529,2,1,0)
 ;;=Template or form file number is invalid.
 ;;^UTILITY(U,$J,.84,9530,0)
 ;;=9530^1^^11
 ;;^UTILITY(U,$J,.84,9530,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9530,1,1,0)
 ;;=Transport package name is invalid.  (KIDS)
 ;;^UTILITY(U,$J,.84,9530,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9530,2,1,0)
 ;;=Transport package name is invalid.  (DIFROM Server/KIDS)
 ;;^UTILITY(U,$J,.84,9531,0)
 ;;=9531^1^^11
 ;;^UTILITY(U,$J,.84,9531,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9531,1,1,0)
 ;;=Invalid EDE(s).
 ;;^UTILITY(U,$J,.84,9531,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9531,2,1,0)
 ;;=Invalid EDE(s).  (DIFROM Server/KIDS)

DINIT015
DINIT015 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,9532,0)
 ;;=9532^1^^11
 ;;^UTILITY(U,$J,.84,9532,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9532,1,1,0)
 ;;=No IEN(s) in array.  (KIDS)
 ;;^UTILITY(U,$J,.84,9532,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9532,2,1,0)
 ;;=No IEN(s) in list.
 ;;^UTILITY(U,$J,.84,9533,0)
 ;;=9533^1^^11
 ;;^UTILITY(U,$J,.84,9533,1,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9533,1,1,0)
 ;;=Source array root missing.
 ;;^UTILITY(U,$J,.84,9533,2,0)
 ;;=^^1^1^2940909^
 ;;^UTILITY(U,$J,.84,9533,2,1,0)
 ;;=Source array root missing.
 ;;^UTILITY(U,$J,.84,9534,0)
 ;;=9534^1^y^11
 ;;^UTILITY(U,$J,.84,9534,1,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9534,1,1,0)
 ;;=Resolved value data link missing.
 ;;^UTILITY(U,$J,.84,9534,2,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9534,2,1,0)
 ;;=Resolved Value Data Link missing |1|.
 ;;^UTILITY(U,$J,.84,9535,0)
 ;;=9535^1^y^11
 ;;^UTILITY(U,$J,.84,9535,1,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9535,1,1,0)
 ;;=Pointer file missing.
 ;;^UTILITY(U,$J,.84,9535,2,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9535,2,1,0)
 ;;=Pointer file missing |1|.
 ;;^UTILITY(U,$J,.84,9536,0)
 ;;=9536^1^y^11
 ;;^UTILITY(U,$J,.84,9536,1,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9536,1,1,0)
 ;;=Pointed too file not on target system.
 ;;^UTILITY(U,$J,.84,9536,2,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9536,2,1,0)
 ;;=Pointed too file not on target system |1|.
 ;;^UTILITY(U,$J,.84,9537,0)
 ;;=9537^1^y^11
 ;;^UTILITY(U,$J,.84,9537,1,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9537,1,1,0)
 ;;=Unable to find exact match and resolve pointer.
 ;;^UTILITY(U,$J,.84,9537,2,0)
 ;;=^^1^1^2940909^^^
 ;;^UTILITY(U,$J,.84,9537,2,1,0)
 ;;=Unable to find exact match and resolve pointer |1|.
 ;;^UTILITY(U,$J,.84,9538,0)
 ;;=9538^1^y^11
 ;;^UTILITY(U,$J,.84,9538,1,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9538,1,1,0)
 ;;=Pointer resolved value is missing.
 ;;^UTILITY(U,$J,.84,9538,2,0)
 ;;=^^1^1^2940909^^
 ;;^UTILITY(U,$J,.84,9538,2,1,0)
 ;;=Pointer resolved value is missing |1|.
 ;;^UTILITY(U,$J,.84,9539,0)
 ;;=9539^1^y^11
 ;;^UTILITY(U,$J,.84,9539,1,0)
 ;;=^^1^1^2940914^
 ;;^UTILITY(U,$J,.84,9539,1,1,0)
 ;;=File not on this system.
 ;;^UTILITY(U,$J,.84,9539,2,0)
 ;;=^^1^1^2940914^
 ;;^UTILITY(U,$J,.84,9539,2,1,0)
 ;;=File #|1| not on this system.
 ;;^UTILITY(U,$J,.84,9540,0)
 ;;=9540^1^y^11
 ;;^UTILITY(U,$J,.84,9540,1,0)
 ;;=^^1^1^2940914^^
 ;;^UTILITY(U,$J,.84,9540,1,1,0)
 ;;=DD not on this system.
 ;;^UTILITY(U,$J,.84,9540,2,0)
 ;;=^^1^1^2940914^^
 ;;^UTILITY(U,$J,.84,9540,2,1,0)
 ;;=DD #|1| not on this system.
 ;;^UTILITY(U,$J,.84,9541,0)
 ;;=9541^1^y^11
 ;;^UTILITY(U,$J,.84,9541,1,0)
 ;;=^^1^1^2940914^^
 ;;^UTILITY(U,$J,.84,9541,1,1,0)
 ;;=Field not on this system.
 ;;^UTILITY(U,$J,.84,9541,2,0)
 ;;=^^1^1^2940914^^
 ;;^UTILITY(U,$J,.84,9541,2,1,0)
 ;;=Field #|1|, DD #|2|, not on this system.
 ;;^UTILITY(U,$J,.84,9542,0)
 ;;=9542^1^^11
 ;;^UTILITY(U,$J,.84,9542,1,0)
 ;;=^^1^1^2940914^
 ;;^UTILITY(U,$J,.84,9542,1,1,0)
 ;;=File number missing or invalid for FIA structure.
 ;;^UTILITY(U,$J,.84,9542,2,0)
 ;;=^^1^1^2940914^
 ;;^UTILITY(U,$J,.84,9542,2,1,0)
 ;;=File number missing or invalid to build FIA structure.
 ;;^UTILITY(U,$J,.84,10001,0)
 ;;=10001^3^y^11
 ;;^UTILITY(U,$J,.84,10001,1,0)
 ;;=^^2^2^2941121^^
 ;;^UTILITY(U,$J,.84,10001,1,1,0)
 ;;=Here we enter a description of the help message itself.  This
 ;;^UTILITY(U,$J,.84,10001,1,2,0)
 ;;=description is for our own documentation.
 ;;^UTILITY(U,$J,.84,10001,2,0)
 ;;=^^3^3^2941121^^
 ;;^UTILITY(U,$J,.84,10001,2,1,0)
 ;;=Here we enter the actual text of the help messages, with
 ;;^UTILITY(U,$J,.84,10001,2,2,0)
 ;;=parameters designated by vertical bars |1
 ;;^UTILITY(U,$J,.84,10001,2,3,0)
 ;;=| as shown.
 ;;^UTILITY(U,$J,.84,10001,3,0)
 ;;=^.845^1^1
 ;;^UTILITY(U,$J,.84,10001,3,1,0)
 ;;=1^Brief description of parameter 1 goes here.  For documentation only.
 ;;^UTILITY(U,$J,.84,10001,4,0)
 ;;=^.847P^^0
 ;;^UTILITY(U,$J,.84,10001,6)
 ;;=S MYVAR="HELP #10001 WAS REQUESTED"
 ;;^UTILITY(U,$J,.84,99000,0)
 ;;=99000^1^y^11
 ;;^UTILITY(U,$J,.84,99000,1,0)
 ;;=^^1^1^2940915^
 ;;^UTILITY(U,$J,.84,99000,1,1,0)
 ;;=FOR TESTING ONLY.
 ;;^UTILITY(U,$J,.84,99000,2,0)
 ;;=^^2^2^2940915^
 ;;^UTILITY(U,$J,.84,99000,2,1,0)
 ;;=TESTING ERROR MESSAGE
 ;;^UTILITY(U,$J,.84,99000,2,2,0)
 ;;=parameter |1|;  parameter |2|.
 ;;^UTILITY(U,$J,.84,99000,3,0)
 ;;=^.845^3^3

DINIT016
DINIT016 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.84,99000,3,1,0)
 ;;=1^first parameter
 ;;^UTILITY(U,$J,.84,99000,3,2,0)
 ;;=2^second parameter
 ;;^UTILITY(U,$J,.84,99000,3,3,0)
 ;;=A^a non-print parameter
 ;;^UTILITY(U,$J,.84,99000,6)
 ;;=D:ZZGO MSG^DIALOG("SWATEHM",.ZZCOPY,"",20)
 ;;^UTILITY(U,$J,.84,99001,0)
 ;;=99001^3^y^11
 ;;^UTILITY(U,$J,.84,99001,1,0)
 ;;=^^1^1^2940915^
 ;;^UTILITY(U,$J,.84,99001,1,1,0)
 ;;=A help test message.
 ;;^UTILITY(U,$J,.84,99001,2,0)
 ;;=^^1^1^2940915^
 ;;^UTILITY(U,$J,.84,99001,2,1,0)
 ;;=Help |1|!!
 ;;^UTILITY(U,$J,.84,99002,0)
 ;;=99002^2^^11
 ;;^UTILITY(U,$J,.84,99002,1,0)
 ;;=^^1^1^2940915^
 ;;^UTILITY(U,$J,.84,99002,1,1,0)
 ;;=A general message testing message.
 ;;^UTILITY(U,$J,.84,99002,2,0)
 ;;=^^1^1^2940915^
 ;;^UTILITY(U,$J,.84,99002,2,1,0)
 ;;=A message.

DINIT017
DINIT017 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC(.85,0,"GL")
 ;;=^DI(.85,
 ;;^DIC("B","LANGUAGE",.85)
 ;;=
 ;;^DIC(.85,"%",0)
 ;;=^1.005
 ;;^DIC(.85,"%D",0)
 ;;=^^7^7^2941122^
 ;;^DIC(.85,"%D",1,0)
 ;;=The LANGUAGE file is used both to officially identify a language, and to
 ;;^DIC(.85,"%D",2,0)
 ;;=store MUMPS code needed to do language-specific conversions of data such
 ;;^DIC(.85,"%D",3,0)
 ;;=as dates and numbers.  VA FileMan currently distributes only the English
 ;;^DIC(.85,"%D",4,0)
 ;;=language entry for this file (entry number 1).  This code is currently
 ;;^DIC(.85,"%D",5,0)
 ;;=available for use only within VA FileMan.  A pointer to this file from the
 ;;^DIC(.85,"%D",6,0)
 ;;=TRANSLATION multiple on the DIALOG file also allows non-English text to be
 ;;^DIC(.85,"%D",7,0)
 ;;=returned via FileMan calls.
 ;;^DD(.85,0)
 ;;=FIELD^^20.2^9
 ;;^DD(.85,0,"DDA")
 ;;=N
 ;;^DD(.85,0,"DT")
 ;;=2940714
 ;;^DD(.85,0,"ID",1)
 ;;=W "   ",$P(^(0),U,2)
 ;;^DD(.85,0,"IX","B",.85,.01)
 ;;=
 ;;^DD(.85,0,"IX","C",.85,1)
 ;;=
 ;;^DD(.85,0,"NM","LANGUAGE")
 ;;=
 ;;^DD(.85,0,"PT",.847,.01)
 ;;=
 ;;^DD(.85,.01,0)
 ;;=ID NUMBER^RNJ10,0X^^0;1^K:+X'=X!(X>9999999999)!(X<1)!(X?.E1"."1N.N) X S:$G(X) DINUM=X
 ;;^DD(.85,.01,.1)
 ;;=Language-ID-Number
 ;;^DD(.85,.01,1,0)
 ;;=^.1
 ;;^DD(.85,.01,1,1,0)
 ;;=.85^B
 ;;^DD(.85,.01,1,1,1)
 ;;=S ^DI(.85,"B",$E(X,1,30),DA)=""
 ;;^DD(.85,.01,1,1,2)
 ;;=K ^DI(.85,"B",$E(X,1,30),DA)
 ;;^DD(.85,.01,3)
 ;;=Type a Number between 1 and 9999999999, 0 Decimal Digits
 ;;^DD(.85,.01,21,0)
 ;;=^^3^3^2941121^^
 ;;^DD(.85,.01,21,1,0)
 ;;=A number that is used to uniquely identify a language.  This number
 ;;^DD(.85,.01,21,2,0)
 ;;=corresponds to the FileMan system variable DUZ("LANG"), which is set
 ;;^DD(.85,.01,21,3,0)
 ;;=during Kernel signon to signify which language FileMan should use.
 ;;^DD(.85,.01,"DT")
 ;;=2940524
 ;;^DD(.85,1,0)
 ;;=NAME^RF^^0;2^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.85,1,.1)
 ;;=Language-Name
 ;;^DD(.85,1,1,0)
 ;;=^.1
 ;;^DD(.85,1,1,1,0)
 ;;=.85^C
 ;;^DD(.85,1,1,1,1)
 ;;=S ^DI(.85,"C",$E(X,1,30),DA)=""
 ;;^DD(.85,1,1,1,2)
 ;;=K ^DI(.85,"C",$E(X,1,30),DA)
 ;;^DD(.85,1,1,1,"DT")
 ;;=2940307
 ;;^DD(.85,1,3)
 ;;=Answer must be 1-30 characters in length. (e.g., ENGLISH, GERMAN, FRENCH)
 ;;^DD(.85,1,21,0)
 ;;=^^2^2^2941121^
 ;;^DD(.85,1,21,1,0)
 ;;=The descriptive name of the language corresponding to this entry (i.e.,
 ;;^DD(.85,1,21,2,0)
 ;;=German, Spanish).
 ;;^DD(.85,1,"DT")
 ;;=2940524
 ;;^DD(.85,10.1,0)
 ;;=ORDINAL NUMBER FORMAT^K^^ORD;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.1,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.1,9)
 ;;=@
 ;;^DD(.85,10.1,21,0)
 ;;=^^6^6^2941121^^^^
 ;;^DD(.85,10.1,21,1,0)
 ;;=MUMPS code used to transfer a number in Y to its ordinal equivalent in
 ;;^DD(.85,10.1,21,2,0)
 ;;=this language. The code should set Y to the ordinal equivalent without
 ;;^DD(.85,10.1,21,3,0)
 ;;=altering any other variables in the environment.  Ex. in English:
 ;;^DD(.85,10.1,21,4,0)
 ;;=       Y=1     becomes         Y=1ST
 ;;^DD(.85,10.1,21,5,0)
 ;;=       Y=2     becomes         Y=2ND
 ;;^DD(.85,10.1,21,6,0)
 ;;=       Y=3     becomes         Y=3RD  etc.
 ;;^DD(.85,10.1,"DT")
 ;;=2940307
 ;;^DD(.85,10.2,0)
 ;;=DATE/TIME FORMAT^K^^DD;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.2,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.2,9)
 ;;=@
 ;;^DD(.85,10.2,21,0)
 ;;=^^6^6^2941121^^^
 ;;^DD(.85,10.2,21,1,0)
 ;;=MUMPS code used to transfer a date or date/time in Y from FileMan internal
 ;;^DD(.85,10.2,21,2,0)
 ;;=format, to printable format equivalent to English MMM DD,YYYY@HH.MM.SS.
 ;;^DD(.85,10.2,21,3,0)
 ;;=The code should set Y to the output, without altering any other variables
 ;;^DD(.85,10.2,21,4,0)
 ;;=in the environment.  Ex. in English:
 ;;^DD(.85,10.2,21,5,0)
 ;;= 
 ;;^DD(.85,10.2,21,6,0)
 ;;=       Y=2940612.031245        becomes         Y=JUN 12,1994@03:12:45
 ;;^DD(.85,10.2,"DT")
 ;;=2940307
 ;;^DD(.85,10.21,0)
 ;;=DATE/TIME FORMAT (FMTE)^K^^FMTE;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.21,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.21,9)
 ;;=@
 ;;^DD(.85,10.21,21,0)
 ;;=^^22^22^2941122^
 ;;^DD(.85,10.21,21,1,0)
 ;;=MUMPS code used to transfer a date or date/time in Y from FileMan internal
 ;;^DD(.85,10.21,21,2,0)
 ;;=format, to printable format based on the various outputs from routine
 ;;^DD(.85,10.21,21,3,0)
 ;;=FMTE^DILIBF.  This is an extrinsic function.  Coming in to this MUMPS

DINIT018
DINIT018 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.85,10.21,21,4,0)
 ;;=code, in addition to the internal date in Y, a third parameter will be
 ;;^DD(.85,10.21,21,5,0)
 ;;=defined to contain flags equivalent to the flag passed as the second input
 ;;^DD(.85,10.21,21,6,0)
 ;;=parameter to FMTE^DILIBF. The code should set Y to the output, without
 ;;^DD(.85,10.21,21,7,0)
 ;;=altering any other variables in the environment.  The output should be
 ;;^DD(.85,10.21,21,8,0)
 ;;=formatted based on these flags:
 ;;^DD(.85,10.21,21,9,0)
 ;;= 
 ;;^DD(.85,10.21,21,10,0)
 ;;= 1    MMM DD, YYYY@HH:MM:SS
 ;;^DD(.85,10.21,21,11,0)
 ;;= 2    MM/DD/YY@HH:MM:SS     no leading zeroes on month,day
 ;;^DD(.85,10.21,21,12,0)
 ;;= 3    DD/MM/YY@HH:MM:SS     no leading zeroes on month,day
 ;;^DD(.85,10.21,21,13,0)
 ;;= 4    YY/MM/DD@HH:MM:SS
 ;;^DD(.85,10.21,21,14,0)
 ;;= 5    MMM DD,YYYY@HH:MM:SS  no space before year,no leading zero on day
 ;;^DD(.85,10.21,21,15,0)
 ;;= 6    MM-DD-YYYY @ HH:MM:SS spaces separate time 
 ;;^DD(.85,10.21,21,16,0)
 ;;= 7    MM-DD-YYYY@HH:MM:SS   no leading zeroes on month,day
 ;;^DD(.85,10.21,21,17,0)
 ;;= 
 ;;^DD(.85,10.21,21,18,0)
 ;;=letters in the flag
 ;;^DD(.85,10.21,21,19,0)
 ;;= S    return always seconds
 ;;^DD(.85,10.21,21,20,0)
 ;;= U    return uppercase month names
 ;;^DD(.85,10.21,21,21,0)
 ;;= P    return time as am,pm
 ;;^DD(.85,10.21,21,22,0)
 ;;= D    return only date part
 ;;^DD(.85,10.21,"DT")
 ;;=2940624
 ;;^DD(.85,10.3,0)
 ;;=CARDINAL NUMBER FORMAT^K^^CRD;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.3,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.3,9)
 ;;=@
 ;;^DD(.85,10.3,21,0)
 ;;=^^5^5^2941121^^
 ;;^DD(.85,10.3,21,1,0)
 ;;=MUMPS code used to transfer a number in Y to its cardinal equivalent in
 ;;^DD(.85,10.3,21,2,0)
 ;;=this language. The code should set Y to the cardinal equivalent without
 ;;^DD(.85,10.3,21,3,0)
 ;;=altering any other variables in the environment.  Ex. in English:
 ;;^DD(.85,10.3,21,4,0)
 ;;=       Y=2000     becomes         Y=2,000
 ;;^DD(.85,10.3,21,5,0)
 ;;=       Y=1234567  becomes         Y=1,234,567
 ;;^DD(.85,10.3,"DT")
 ;;=2940308
 ;;^DD(.85,10.4,0)
 ;;=UPPERCASE CONVERSION^K^^UC;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.4,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.4,9)
 ;;=@
 ;;^DD(.85,10.4,21,0)
 ;;=^^4^4^2941121^
 ;;^DD(.85,10.4,21,1,0)
 ;;=MUMPS code used to convert text in Y to its upper-case equivalent in
 ;;^DD(.85,10.4,21,2,0)
 ;;=this language. The code should set Y to the external format without
 ;;^DD(.85,10.4,21,3,0)
 ;;=altering any other variables in the environment.  In English, changes
 ;;^DD(.85,10.4,21,4,0)
 ;;=   abCdeF      to: ABCDEF
 ;;^DD(.85,10.4,"DT")
 ;;=2940308
 ;;^DD(.85,10.5,0)
 ;;=LOWERCASE CONVERSION^K^^LC;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,10.5,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,10.5,9)
 ;;=@
 ;;^DD(.85,10.5,21,0)
 ;;=^^4^4^2941121^
 ;;^DD(.85,10.5,21,1,0)
 ;;=MUMPS code used to convert text in Y to its lower-case equivalent in  
 ;;^DD(.85,10.5,21,2,0)
 ;;=this language. The code should set Y to the external format without
 ;;^DD(.85,10.5,21,3,0)
 ;;=altering any other variables in the environment.  In English, changes:
 ;;^DD(.85,10.5,21,4,0)
 ;;=    ABcdEFgHij         to:  abcdefghij
 ;;^DD(.85,10.5,"DT")
 ;;=2940308
 ;;^DD(.85,20.2,0)
 ;;=DATE INPUT^K^^20.2;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.85,20.2,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.85,20.2,9)
 ;;=@
 ;;^DD(.85,20.2,"DT")
 ;;=2940714

DINIT019
DINIT019 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 12/22/94  09:32:23
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^UTILITY(U,$J,.85)
 ;;=^DI(.85,
 ;;^UTILITY(U,$J,.85,0)
 ;;=LANGUAGE^.85I^4^4
 ;;^UTILITY(U,$J,.85,1,0)
 ;;=1^ENGLISH
 ;;^UTILITY(U,$J,.85,1,"CRD")
 ;;=I Y S Y=$FN(Y,",")
 ;;^UTILITY(U,$J,.85,1,"DD")
 ;;=S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)_$S($E(Y,13,14):":"_$E(Y_0,13,14),1:""),"^",Y[".")
 ;;^UTILITY(U,$J,.85,1,"FMTE")
 ;;=N RTN,%T S %T="."_$E($P(Y,".",2)_"000000",1,7),%F=$G(%F),RTN="F"_$S(%F<1:1,%F>7:1,1:+%F\1)_"^DILIBF" D @RTN S Y=%R
 ;;^UTILITY(U,$J,.85,1,"LC")
 ;;=S Y=$TR(Y,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
 ;;^UTILITY(U,$J,.85,1,"ORD")
 ;;=I $G(Y) S Y=Y_$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH")
 ;;^UTILITY(U,$J,.85,1,"UC")
 ;;=S Y=$TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;;^UTILITY(U,$J,.85,2,0)
 ;;=2^GERMAN
 ;;^UTILITY(U,$J,.85,3,0)
 ;;=3^SPANISH
 ;;^UTILITY(U,$J,.85,4,0)
 ;;=4^FRENCH

DINIT02
DINIT02 ;SFISC/DPC-EXPORT TOOL PRINT TEMPLATES ;2/24/93  13:17
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT03 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIPT(.441,0)
 ;;=DDXP FORMAT DOC^2921023.1533^@^.44^^@^2921130
 ;;^DIPT(.441,"F",2)
 ;;="DESCRIPTION:";S~30,.01~"USAGE NOTE:";C2;S~31,.01~50,"OTHER NAME:";C5;S~50,.01~50,"DESCRIPTION:";C8;S~50,1,.01~
 ;;^DIPT(.441,"H")
 ;;=AVAILABLE FORMATS
 ;;^DIPT(.442,0)
 ;;=DDXP FORMAT DOC HDR^2921112.1536^@^.44^^@^2921130
 ;;^DIPT(.442,"F",1)
 ;;="AVAILABLE FOREIGN FORMATS"~S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) S Y=X D DT K DIP;C45;L18;Z;"NOW"~
 ;;^DIPT(.442,"F",2)
 ;;=S X="Page ",DIP(1)=X,X=$S($D(DC)#2:DC,1:"") S Y=X,X=DIP(1),X=X S X=X_Y W X K DIP;C67;Z;""Page "_PAGE"~
 ;;^DIPT(.442,"F",3)
 ;;=S X="_",DIP(1)=X,DIP(2)=X,X=$S($D(IOM):IOM,1:80) S X=X,X1=DIP(1) S %=X,X="" Q:X1=""  S $P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%) W X K DIP;C1;Z;"DUP("_",IOM)"~
 ;;^DIPT(.442,"H")
 ;;=@

DINIT03
DINIT03 ;SFISC/DPC-FORM FOR FOREIGN FORMATS ;2/24/93  13:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT04 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.403,.441,0)
 ;;=DDXP FF FORM1^^^^2920925^2921112.085213^^.44
 ;;^DIST(.403,.441,20)
 ;;=D FORMVAL^DDXP1
 ;;^DIST(.403,.441,40,0)
 ;;=^.4031I^3^3
 ;;^DIST(.403,.441,40,1,0)
 ;;=1^^1,1^2^2^0
 ;;^DIST(.403,.441,40,1,1)
 ;;=PAGE 1
 ;;^DIST(.403,.441,40,1,15,0)
 ;;=^^1^1^2920925^^
 ;;^DIST(.403,.441,40,1,15,1,0)
 ;;=First page for Foreign Format definition.  It contains block DDXP FF BLK1.
 ;;^DIST(.403,.441,40,1,40,0)
 ;;=^.4032PI^.441^1
 ;;^DIST(.403,.441,40,1,40,.441,0)
 ;;=.441^1^1,1^e
 ;;^DIST(.403,.441,40,1,40,"AC",1,.441)
 ;;=
 ;;^DIST(.403,.441,40,1,40,"B",.441,.441)
 ;;=
 ;;^DIST(.403,.441,40,2,0)
 ;;=2^^1,1^1^1^0
 ;;^DIST(.403,.441,40,2,1)
 ;;=PAGE 2
 ;;^DIST(.403,.441,40,2,15,0)
 ;;=^^2^2^2920925^
 ;;^DIST(.403,.441,40,2,15,1,0)
 ;;=Page 2 of the form used to define a Foreign Format.  It contains block
 ;;^DIST(.403,.441,40,2,15,2,0)
 ;;=DDXP FF BLK2 and subpage containing DDXP FF BLK3.
 ;;^DIST(.403,.441,40,2,40,0)
 ;;=^.4032PI^.442^1
 ;;^DIST(.403,.441,40,2,40,.442,0)
 ;;=.442^1^1,1^e
 ;;^DIST(.403,.441,40,2,40,"AC",1,.442)
 ;;=
 ;;^DIST(.403,.441,40,2,40,"B",.442,.442)
 ;;=
 ;;^DIST(.403,.441,40,3,0)
 ;;=3^^12,23^^^1^16,59
 ;;^DIST(.403,.441,40,3,1)
 ;;=POP-UP PAGE 1
 ;;^DIST(.403,.441,40,3,15,0)
 ;;=^^2^2^2920925^^
 ;;^DIST(.403,.441,40,3,15,1,0)
 ;;=This pop-up page is called from page 2 of DDXP FF FORM1.  It contains
 ;;^DIST(.403,.441,40,3,15,2,0)
 ;;=block DDXP FF BLK3, which has the OTHER NAME FOR FORMAT multiple.
 ;;^DIST(.403,.441,40,3,40,0)
 ;;=^.4032PI^.443^1
 ;;^DIST(.403,.441,40,3,40,.443,0)
 ;;=.443^1^1,1^e
 ;;^DIST(.403,.441,40,3,40,"AC",1,.443)
 ;;=
 ;;^DIST(.403,.441,40,3,40,"B",.443,.443)
 ;;=
 ;;^DIST(.403,.441,40,"B",1,1)
 ;;=
 ;;^DIST(.403,.441,40,"B",2,2)
 ;;=
 ;;^DIST(.403,.441,40,"B",3,3)
 ;;=
 ;;^DIST(.403,.441,40,"C","PAGE 1",1)
 ;;=
 ;;^DIST(.403,.441,40,"C","PAGE 2",2)
 ;;=
 ;;^DIST(.403,.441,40,"C","POP-UP PAGE 1",3)
 ;;=

DINIT04
DINIT04 ;ISCSF/DPC - BLOCK1 FOR FOREIGN FORMAT;1/11/93  2:19 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT05 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.441,0)
 ;;=DDXP FF BLK1^.44
 ;;^DIST(.404,.441,15,0)
 ;;=^^2^2^2930107^^^^
 ;;^DIST(.404,.441,15,1,0)
 ;;=Block makes up page 1 of DDXP FF FORM.  It is used to define a foreign
 ;;^DIST(.404,.441,15,2,0)
 ;;=format.
 ;;^DIST(.404,.441,40,0)
 ;;=^.4044I^21^16
 ;;^DIST(.404,.441,40,1,0)
 ;;=1^FOREIGN FILE FORMAT^0^
 ;;^DIST(.404,.441,40,1,1)
 ;;=.01
 ;;^DIST(.404,.441,40,1,2)
 ;;=1,42^30^1,21^0
 ;;^DIST(.404,.441,40,3,0)
 ;;=3^!M^1^
 ;;^DIST(.404,.441,40,3,.1)
 ;;=N I S Y="" F I=1:1:21+$L($G(DDXPFMNM)) S Y=Y_"="
 ;;^DIST(.404,.441,40,3,2)
 ;;=^^2,21^
 ;;^DIST(.404,.441,40,4,0)
 ;;=4^FIELD DELIMITER^0
 ;;^DIST(.404,.441,40,4,1)
 ;;=1
 ;;^DIST(.404,.441,40,4,2)
 ;;=4,23^15^4,6^0
 ;;^DIST(.404,.441,40,5,0)
 ;;=5^RECORD LENGTH FIXED?^0
 ;;^DIST(.404,.441,40,5,1)
 ;;=5
 ;;^DIST(.404,.441,40,5,2)
 ;;=4,69^3^4,48^1
 ;;^DIST(.404,.441,40,6,0)
 ;;=4.7^RECORD DELIMITER^0
 ;;^DIST(.404,.441,40,6,1)
 ;;=2
 ;;^DIST(.404,.441,40,6,2)
 ;;=6,23^15^6,5^0
 ;;^DIST(.404,.441,40,7,0)
 ;;=7^MAXIMUM OUTPUT LENGTH^0
 ;;^DIST(.404,.441,40,7,1)
 ;;=7
 ;;^DIST(.404,.441,40,7,2)
 ;;=5,69^5^5,46^0
 ;;^DIST(.404,.441,40,7,3)
 ;;=80
 ;;^DIST(.404,.441,40,8,0)
 ;;=8^NEED FOREIGN FIELD NAMES?^0
 ;;^DIST(.404,.441,40,8,1)
 ;;=6
 ;;^DIST(.404,.441,40,8,2)
 ;;=6,69^3^6,43^1
 ;;^DIST(.404,.441,40,9,0)
 ;;=9^FILE HEADER^0
 ;;^DIST(.404,.441,40,9,1)
 ;;=20
 ;;^DIST(.404,.441,40,9,2)
 ;;=8,23^40^8,10^0
 ;;^DIST(.404,.441,40,10,0)
 ;;=10^FILE TRAILER^0
 ;;^DIST(.404,.441,40,10,1)
 ;;=25
 ;;^DIST(.404,.441,40,10,2)
 ;;=9,23^40^9,9^0
 ;;^DIST(.404,.441,40,11,0)
 ;;=11^DATE FORMAT^0
 ;;^DIST(.404,.441,40,11,1)
 ;;=27
 ;;^DIST(.404,.441,40,11,2)
 ;;=10,23^40^10,10^0
 ;;^DIST(.404,.441,40,16,0)
 ;;=16^Go to next page to document format.^1^
 ;;^DIST(.404,.441,40,16,2)
 ;;=^^17,45^
 ;;^DIST(.404,.441,40,17,0)
 ;;=2^PAGE 1^1^
 ;;^DIST(.404,.441,40,17,2)
 ;;=^^1,74^
 ;;^DIST(.404,.441,40,18,0)
 ;;=12^QUOTE NON-NUMERIC?^0
 ;;^DIST(.404,.441,40,18,1)
 ;;=8
 ;;^DIST(.404,.441,40,18,2)
 ;;=13,23^3^13,4^1
 ;;^DIST(.404,.441,40,19,0)
 ;;=13^PROMPT FOR DATA TYPE?^0
 ;;^DIST(.404,.441,40,19,1)
 ;;=9
 ;;^DIST(.404,.441,40,19,2)
 ;;=14,23^3^14,1^1
 ;;^DIST(.404,.441,40,20,0)
 ;;=4.5^SEND LAST DELIMITER?^0
 ;;^DIST(.404,.441,40,20,1)
 ;;=10
 ;;^DIST(.404,.441,40,20,2)
 ;;=5,23^3^5,2^1
 ;;^DIST(.404,.441,40,20,3)
 ;;=YES
 ;;^DIST(.404,.441,40,21,0)
 ;;=11.5^SUBSTITUTE FOR NULL^0
 ;;^DIST(.404,.441,40,21,1)
 ;;=11
 ;;^DIST(.404,.441,40,21,2)
 ;;=12,23^15^12,2^0
 ;;^DIST(.404,.441,40,"B",1,1)
 ;;=
 ;;^DIST(.404,.441,40,"B",2,17)
 ;;=
 ;;^DIST(.404,.441,40,"B",3,3)
 ;;=
 ;;^DIST(.404,.441,40,"B",4,4)
 ;;=
 ;;^DIST(.404,.441,40,"B",4.5,20)
 ;;=
 ;;^DIST(.404,.441,40,"B",4.7,6)
 ;;=
 ;;^DIST(.404,.441,40,"B",5,5)
 ;;=
 ;;^DIST(.404,.441,40,"B",7,7)
 ;;=
 ;;^DIST(.404,.441,40,"B",8,8)
 ;;=
 ;;^DIST(.404,.441,40,"B",9,9)
 ;;=
 ;;^DIST(.404,.441,40,"B",10,10)
 ;;=
 ;;^DIST(.404,.441,40,"B",11,11)
 ;;=
 ;;^DIST(.404,.441,40,"B",11.5,21)
 ;;=
 ;;^DIST(.404,.441,40,"B",12,18)
 ;;=
 ;;^DIST(.404,.441,40,"B",13,19)
 ;;=
 ;;^DIST(.404,.441,40,"B",16,16)
 ;;=
 ;;^DIST(.404,.441,40,"C","DATE FORMAT",11)
 ;;=
 ;;^DIST(.404,.441,40,"C","FIELD DELIMITER",4)
 ;;=
 ;;^DIST(.404,.441,40,"C","FILE HEADER",9)
 ;;=
 ;;^DIST(.404,.441,40,"C","FILE TRAILER",10)
 ;;=
 ;;^DIST(.404,.441,40,"C","FOREIGN FILE FORMAT",1)
 ;;=
 ;;^DIST(.404,.441,40,"C","GO TO NEXT PAGE TO DOCUMENT FORMAT.",16)
 ;;=
 ;;^DIST(.404,.441,40,"C","MAXIMUM OUTPUT LENGTH",7)
 ;;=
 ;;^DIST(.404,.441,40,"C","NEED FOREIGN FIELD NAMES?",8)
 ;;=
 ;;^DIST(.404,.441,40,"C","PAGE 1",17)
 ;;=
 ;;^DIST(.404,.441,40,"C","PROMPT FOR DATA TYPE?",19)
 ;;=
 ;;^DIST(.404,.441,40,"C","QUOTE NON-NUMERIC?",18)
 ;;=
 ;;^DIST(.404,.441,40,"C","RECORD DELIMITER",6)
 ;;=
 ;;^DIST(.404,.441,40,"C","RECORD LENGTH FIXED?",5)
 ;;=
 ;;^DIST(.404,.441,40,"C","SEND LAST DELIMITER?",20)
 ;;=
 ;;^DIST(.404,.441,40,"C","SUBSTITUTE FOR NULL",21)
 ;;=

DINIT05
DINIT05 ;SFISC/DPC-BLOCK FOR FOREIGN FORMAT ;12/1/92  10:59 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT06 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.442,0)
 ;;=DDXP FF BLK2^.44^0
 ;;^DIST(.404,.442,15,0)
 ;;=^^2^2^2920925^^^
 ;;^DIST(.404,.442,15,1,0)
 ;;=Contains fields for page 2 of form used to define Foreign Formats.
 ;;^DIST(.404,.442,15,2,0)
 ;;=Primarily used to document the format.
 ;;^DIST(.404,.442,40,0)
 ;;=^.4044I^7^7
 ;;^DIST(.404,.442,40,1,0)
 ;;=1^FOREIGN FILE FORMAT: ^1^
 ;;^DIST(.404,.442,40,1,2)
 ;;=^^1,21^
 ;;^DIST(.404,.442,40,2,0)
 ;;=2^^0
 ;;^DIST(.404,.442,40,2,1)
 ;;=.01
 ;;^DIST(.404,.442,40,2,2)
 ;;=1,42^30
 ;;^DIST(.404,.442,40,2,4)
 ;;=^^^1
 ;;^DIST(.404,.442,40,3,0)
 ;;=2.5^PAGE 2^1^
 ;;^DIST(.404,.442,40,3,2)
 ;;=^^1,74^
 ;;^DIST(.404,.442,40,4,0)
 ;;=3^!M^1^
 ;;^DIST(.404,.442,40,4,.1)
 ;;=N I S Y="" F I=1:1:21+$L($G(DDXPFMNM)) S Y=Y_"="
 ;;^DIST(.404,.442,40,4,2)
 ;;=^^2,21^
 ;;^DIST(.404,.442,40,5,0)
 ;;=4^DESCRIPTION (WP)^0
 ;;^DIST(.404,.442,40,5,1)
 ;;=30
 ;;^DIST(.404,.442,40,5,2)
 ;;=4,44^1^4,26^0
 ;;^DIST(.404,.442,40,6,0)
 ;;=5^USAGE NOTES (WP)^0
 ;;^DIST(.404,.442,40,6,1)
 ;;=31
 ;;^DIST(.404,.442,40,6,2)
 ;;=6,44^1^6,26^0
 ;;^DIST(.404,.442,40,7,0)
 ;;=6^Select OTHER NAME FOR FORMAT^0
 ;;^DIST(.404,.442,40,7,1)
 ;;=50
 ;;^DIST(.404,.442,40,7,2)
 ;;=10,44^22^10,14^0
 ;;^DIST(.404,.442,40,7,4)
 ;;=^^^^0
 ;;^DIST(.404,.442,40,7,7)
 ;;=^3
 ;;^DIST(.404,.442,40,"B",1,1)
 ;;=
 ;;^DIST(.404,.442,40,"B",2,2)
 ;;=
 ;;^DIST(.404,.442,40,"B",2.5,3)
 ;;=
 ;;^DIST(.404,.442,40,"B",3,4)
 ;;=
 ;;^DIST(.404,.442,40,"B",4,5)
 ;;=
 ;;^DIST(.404,.442,40,"B",5,6)
 ;;=
 ;;^DIST(.404,.442,40,"B",6,7)
 ;;=
 ;;^DIST(.404,.442,40,"C","DESCRIPTION (WP)",5)
 ;;=
 ;;^DIST(.404,.442,40,"C","FOREIGN FILE FORMAT: ",1)
 ;;=
 ;;^DIST(.404,.442,40,"C","OTHER NAME FOR FORMAT",7)
 ;;=
 ;;^DIST(.404,.442,40,"C","PAGE 2",3)
 ;;=
 ;;^DIST(.404,.442,40,"C","USAGE NOTES (WP)",6)
 ;;=

DINIT06
DINIT06 ;SFISC/DPC-BLOCK FOR FOREIGN FORMAT ;1/11/93  14:13
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT07 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.443,0)
 ;;=DDXP FF BLK3^.441^0
 ;;^DIST(.404,.443,15,0)
 ;;=^^2^2^2920925^^
 ;;^DIST(.404,.443,15,1,0)
 ;;=Block for subpage containing fields from the OTHER NAME FOR FORMAT
 ;;^DIST(.404,.443,15,2,0)
 ;;=multiple.  Used in defining a foreign file format.
 ;;^DIST(.404,.443,40,0)
 ;;=^.4044I^2^2
 ;;^DIST(.404,.443,40,1,0)
 ;;=1^OTHER NAME^0
 ;;^DIST(.404,.443,40,1,1)
 ;;=.01
 ;;^DIST(.404,.443,40,1,2)
 ;;=2,20^15^2,8^0
 ;;^DIST(.404,.443,40,2,0)
 ;;=2^DESCRIPTION (WP)^0
 ;;^DIST(.404,.443,40,2,1)
 ;;=1
 ;;^DIST(.404,.443,40,2,2)
 ;;=4,20^1^4,2^0
 ;;^DIST(.404,.443,40,"B",1,1)
 ;;=
 ;;^DIST(.404,.443,40,"B",2,2)
 ;;=
 ;;^DIST(.404,.443,40,"C","DESCRIPTION (WP)",2)
 ;;=
 ;;^DIST(.404,.443,40,"C","OTHER NAME",1)
 ;;=

DINIT07
DINIT07 ;ISCSF/DPC - PACKAGE FILE PRINT TEMPLATE ;6/30/94  13:34
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT08 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIPT(.941,0)
 ;;=DI-PKG-DEFAULT-DEFINITION^2930111.1405^@^9.4^^@^2930111
 ;;^DIPT(.941,"DXS",1,9.2)
 ;;=S DIP(1)=$S($D(^DIC(9.4,D0,4,D1,223)):^(223),1:"") S X=$E(DIP(1),1,245)]"",DIP(2)=X S X="Update screen: "_$E(DIP(1),1,245),DIP(3)=X S X=1,DIP(4)=X S X=""
 ;;^DIPT(.941,"F",1)
 ;;=6,S DIP(1)=$S($D(^DIC(9.4,D0,4,D1,0)):^(0),1:"") S X=$P(DIP(1),U,1),X=X W X K DIP;"FILE #";L10;Z;"INTERNAL(FILE)"~6,.01;L27~6,222.1;"UP DATE THE DD"~
 ;;^DIPT(.941,"F",2)
 ;;=6,222.2;"VER SION #"~6,222.4;"USER OVER RIDE DD"~6,222.7~6,222.8;"MERGE OR OVER WRITE";L4~6,222.9;"USER OVER RIDE DATA"~
 ;;^DIPT(.941,"F",3)
 ;;=6,X DXS(1,9.2) S X=$S(DIP(2):DIP(3),DIP(4):X) K DIP;C13;W66;"";Z;"$S(#223]"":"Update screen: "_#223,1:"")"~
 ;;^DIPT(.941,"F",4)
 ;;="Environment Check Routine          :";S1;C6~913;"";C42~"Pre-Init After User Commit Routine :";C6~916;C42;""~"Post-Initialization Routine        :";C6~
 ;;^DIPT(.941,"F",5)
 ;;=914;"";C42~
 ;;^DIPT(.941,"H")
 ;;=PACKAGE DEFAULT DEFINITION

DINIT08
DINIT08 ;SFISC/TKW - BRING DD FOR FILE .83, COMPILED ROUTINE ;9/9/94  13:33
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT12 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC(.83,0,"GL")
 ;;=^DI(.83,
 ;;^DIC("B","COMPILED ROUTINE",.83)
 ;;=
 ;;^DIC(.83,"%D",0)
 ;;=^^5^5^2940908^
 ;;^DIC(.83,"%D",1,0)
 ;;=This file stores information used for creating compiled SORT routines.
 ;;^DIC(.83,"%D",2,0)
 ;;=During the FileMan SORT/PRINT option, if the user has specified that a
 ;;^DIC(.83,"%D",3,0)
 ;;=sort template is compiled, a routine name is generated by concatenating
 ;;^DIC(.83,"%D",4,0)
 ;;="DIZS" with the next available number from this list.  A flag indicates
 ;;^DIC(.83,"%D",5,0)
 ;;=whether or not a number is currently in use.
 ;;^DD(.83,0)
 ;;=FIELD^^1^2
 ;;^DD(.83,0,"DDA")
 ;;=N
 ;;^DD(.83,0,"DT")
 ;;=2930331
 ;;^DD(.83,0,"IX","B",.83,.01)
 ;;=
 ;;^DD(.83,0,"IX","C",.83,1)
 ;;=
 ;;^DD(.83,0,"NM","COMPILED ROUTINE")
 ;;=
 ;;^DD(.83,.01,0)
 ;;=ROUTINE NUMBER^RNJ4,0X^^0;1^K:+X'=X!(X>9999)!(X<1)!(X?.E1"."1N.N) X S:$D(X) DINUM=X
 ;;^DD(.83,.01,1,0)
 ;;=^.1
 ;;^DD(.83,.01,1,1,0)
 ;;=.83^B
 ;;^DD(.83,.01,1,1,1)
 ;;=S ^DI(.83,"B",$E(X,1,30),DA)=""
 ;;^DD(.83,.01,1,1,2)
 ;;=K ^DI(.83,"B",$E(X,1,30),DA)
 ;;^DD(.83,.01,3)
 ;;=Type a Number between 1 and 9999, 0 Decimal Digits
 ;;^DD(.83,.01,21,0)
 ;;=^^5^5^2930331^^^
 ;;^DD(.83,.01,21,1,0)
 ;;=This is a number that can be used to generate the name of a compiled
 ;;^DD(.83,.01,21,2,0)
 ;;=SORT routine.  The literal 'DIZS' is concatenated with the number to form
 ;;^DD(.83,.01,21,3,0)
 ;;=a compiled sort routine name.  The routine will be in use only during
 ;;^DD(.83,.01,21,4,0)
 ;;=the running of a sort/print.  After the print completes, the number
 ;;^DD(.83,.01,21,5,0)
 ;;=is again made available for use.
 ;;^DD(.83,.01,23,0)
 ;;=^^4^4^2930331^^
 ;;^DD(.83,.01,23,1,0)
 ;;=Generated and used during the FileMan sort/print option.  Manipulated
 ;;^DD(.83,.01,23,2,0)
 ;;=in routine DIOZ, that is called from DIO1.  DIOZ checks a
 ;;^DD(.83,.01,23,3,0)
 ;;=cross-reference on the 'IN USE' flag to find the next available number.
 ;;^DD(.83,.01,23,4,0)
 ;;=If none are available, a new one is added to the file.
 ;;^DD(.83,.01,"DT")
 ;;=2930719
 ;;^DD(.83,1,0)
 ;;=IN USE^S^y:YES, NUMBER IS IN USE;n:NOT IN USE;^0;2^Q
 ;;^DD(.83,1,1,0)
 ;;=^.1
 ;;^DD(.83,1,1,1,0)
 ;;=.83^C
 ;;^DD(.83,1,1,1,1)
 ;;=S ^DI(.83,"C",$E(X,1,30),DA)=""
 ;;^DD(.83,1,1,1,2)
 ;;=K ^DI(.83,"C",$E(X,1,30),DA)
 ;;^DD(.83,1,1,1,"%D",0)
 ;;=^^3^3^2930331^
 ;;^DD(.83,1,1,1,"%D",1,0)
 ;;=This cross-reference is used to control when a routine number is available
 ;;^DD(.83,1,1,1,"%D",2,0)
 ;;=for use in creating a compiled sort routine, during the FileMan sort/print
 ;;^DD(.83,1,1,1,"%D",3,0)
 ;;=option.
 ;;^DD(.83,1,1,1,"DT")
 ;;=2930331
 ;;^DD(.83,1,21,0)
 ;;=^^6^6^2930331^^
 ;;^DD(.83,1,21,1,0)
 ;;=During the running of the FileMan sort/print, if the sort is compiled,
 ;;^DD(.83,1,21,2,0)
 ;;=a cross-reference on this flag is checked to find the first available
 ;;^DD(.83,1,21,3,0)
 ;;=number that is not in use.  The number is then marked in use and is
 ;;^DD(.83,1,21,4,0)
 ;;=concatenated on the end of literal 'DIZS' to create the routine name
 ;;^DD(.83,1,21,5,0)
 ;;=of the compiled routine.  After the sort/print completes, the flag is
 ;;^DD(.83,1,21,6,0)
 ;;=then reset to 'NOT IN USE'.
 ;;^DD(.83,1,23,0)
 ;;=^^5^5^2930331^^
 ;;^DD(.83,1,23,1,0)
 ;;=Manipulated in routine DIOZ that is called from the FileMan sort routine
 ;;^DD(.83,1,23,2,0)
 ;;=DIO1.  The cross-reference on this field is used to control when a number
 ;;^DD(.83,1,23,3,0)
 ;;=is available for use to create a compiled sort routine name.  After
 ;;^DD(.83,1,23,4,0)
 ;;=the sort/print runs, the flag is set back to NOT IN USE so that the
 ;;^DD(.83,1,23,5,0)
 ;;=number is again available.
 ;;^DD(.83,1,"DT")
 ;;=2930331

DINIT0F0
DINIT0F0 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;01:25 PM  23 Nov 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D PRE^DINIT29P
 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
 Q
ENTRY ;
 ;;^DIST(.403,.40301,0)
 ;;=DDGF BLOCK EDIT^^^0^2930413^2941115.0919^^.403^0^0^1
 ;;^DIST(.403,.40301,40,0)
 ;;=^.4031I^2^2
 ;;^DIST(.403,.40301,40,1,0)
 ;;=1^^1,2^^^1^17,77
 ;;^DIST(.403,.40301,40,1,1)
 ;;=Edit Block Parameters
 ;;^DIST(.403,.40301,40,1,40,0)
 ;;=^.4032PI^.403012^2
 ;;^DIST(.403,.40301,40,1,40,.403011,0)
 ;;=.403011^1^1,1^e
 ;;^DIST(.403,.40301,40,1,40,.403012,0)
 ;;=.403012^2^10,1^e
 ;;^DIST(.403,.40301,40,1,40,.403012,1)
 ;;=PAGE:BLOCK:.01
 ;;^DIST(.403,.40301,40,2,0)
 ;;=11^^5,11^^^1^16,65
 ;;^DIST(.403,.40301,40,2,1)
 ;;=Page 11
 ;;^DIST(.403,.40301,40,2,40,0)
 ;;=^.4032PI^.403013^1
 ;;^DIST(.403,.40301,40,2,40,.403013,0)
 ;;=.403013^1^1,1^e
 ;;^DIST(.403,.40302,0)
 ;;=DDGF PAGE ADD^^^0^2930419^2940908.0956^^.403^0^1^1
 ;;^DIST(.403,.40302,40,0)
 ;;=^.4031I^2^2
 ;;^DIST(.403,.40302,40,1,0)
 ;;=1^^4,18^^^1^8,43
 ;;^DIST(.403,.40302,40,1,1)
 ;;=Add a New Page
 ;;^DIST(.403,.40302,40,1,40,0)
 ;;=^.4032PI^.403021^1
 ;;^DIST(.403,.40302,40,1,40,.403021,0)
 ;;=.403021^1^1,1^e
 ;;^DIST(.403,.40302,40,2,0)
 ;;=11^^4,15^^^1^9,49
 ;;^DIST(.403,.40302,40,2,1)
 ;;=Select New Page Number
 ;;^DIST(.403,.40302,40,2,40,0)
 ;;=^.4032PI^.403022^1
 ;;^DIST(.403,.40302,40,2,40,.403022,0)
 ;;=.403022^1^1,1^e
 ;;^DIST(.403,.40303,0)
 ;;=DDGF PAGE EDIT^^^0^2930419^2941115.0829^^.403^0^0^1
 ;;^DIST(.403,.40303,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40303,40,1,0)
 ;;=1^^1,3^^^1^17,77
 ;;^DIST(.403,.40303,40,1,1)
 ;;=Edit a Page
 ;;^DIST(.403,.40303,40,1,40,0)
 ;;=^.4032PI^.403031^1
 ;;^DIST(.403,.40303,40,1,40,.403031,0)
 ;;=.403031^1^1,1^e
 ;;^DIST(.403,.40303,40,1,40,.403031,11)
 ;;=I $$GET^DDSVALF("IS THIS A POP UP PAGE?") N DDGFI F DDGFI="PREVIOUS","NEXT" D UNED^DDSUTL(DDGFI_" PAGE","","",1)
 ;;^DIST(.403,.40304,0)
 ;;=DDGF PAGE SELECT^^^0^2930419^2941122.1340^^.403^0^1^1
 ;;^DIST(.403,.40304,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40304,40,1,0)
 ;;=1^^4,10^^^1^8,56
 ;;^DIST(.403,.40304,40,1,1)
 ;;=Select a Page
 ;;^DIST(.403,.40304,40,1,40,0)
 ;;=^.4032PI^.403041^1
 ;;^DIST(.403,.40304,40,1,40,.403041,0)
 ;;=.403041^1^3,3^e
 ;;^DIST(.403,.40305,0)
 ;;=DDGF FORM EDIT^^^0^2930427^2941115.1504^^.403^0^0^1
 ;;^DIST(.403,.40305,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40305,40,1,0)
 ;;=1^^1,2^^^1^16,76
 ;;^DIST(.403,.40305,40,1,1)
 ;;=Form Edit
 ;;^DIST(.403,.40305,40,1,40,0)
 ;;=^.4032PI^.403051^1
 ;;^DIST(.403,.40305,40,1,40,.403051,0)
 ;;=.403051^1^1,1^e
 ;;^DIST(.403,.40306,0)
 ;;=DDGF HEADER BLOCK EDIT^^^0^2930504^2941115.0924^^.403^0^0^1
 ;;^DIST(.403,.40306,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40306,40,1,0)
 ;;=1^^2,1^^^1^14,76
 ;;^DIST(.403,.40306,40,1,1)
 ;;=Edit/Delete the Header Block
 ;;^DIST(.403,.40306,40,1,40,0)
 ;;=^.4032PI^.403061^2
 ;;^DIST(.403,.40306,40,1,40,.403012,0)
 ;;=.403012^2^5,1^e
 ;;^DIST(.403,.40306,40,1,40,.403012,1)
 ;;=PAGE:1
 ;;^DIST(.403,.40306,40,1,40,.403061,0)
 ;;=.403061^1^1,1^e
 ;;^DIST(.403,.40401,0)
 ;;=DDGF FIELD ADD^^^0^2930331^2941122.1344^^.404^0^1^1
 ;;^DIST(.403,.40401,20)
 ;;=D VAL1^DDGFU
 ;;^DIST(.403,.40401,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40401,40,1,0)
 ;;=1^^4,12^^^1^10,59
 ;;^DIST(.403,.40401,40,1,1)
 ;;=New field
 ;;^DIST(.403,.40401,40,1,40,0)
 ;;=^.4032PI^.404011^1
 ;;^DIST(.403,.40401,40,1,40,.404011,0)
 ;;=.404011^1^3,3^e
 ;;^DIST(.403,.40402,0)
 ;;=DDGF FIELD CAPTION ONLY^^^0^2930409^2941123.13^^.404^0^0^1
 ;;^DIST(.403,.40402,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40402,40,1,0)
 ;;=1^^1,2^^^1^9,75
 ;;^DIST(.403,.40402,40,1,1)
 ;;=Caption only field
 ;;^DIST(.403,.40402,40,1,40,0)
 ;;=^.4032PI^.404021^1
 ;;^DIST(.403,.40402,40,1,40,.404021,0)
 ;;=.404021^1^1,3^e
 ;;^DIST(.403,.40403,0)
 ;;=DDGF FIELD DD^^^0^2930510^2941123.1313^^.404^0^0^1
 ;;^DIST(.403,.40403,40,0)
 ;;=^.4031I^4^4
 ;;^DIST(.403,.40403,40,1,0)
 ;;=1^^1,1^^^1^16,77
 ;;^DIST(.403,.40403,40,1,1)
 ;;=Page 1
 ;;^DIST(.403,.40403,40,1,40,0)
 ;;=^.4032PI^.404031^1
 ;;^DIST(.403,.40403,40,1,40,.404031,0)
 ;;=.404031^1^1,1^e
 ;;^DIST(.403,.40403,40,2,0)
 ;;=11^^3,3^^^1^15,75
 ;;^DIST(.403,.40403,40,2,1)
 ;;=Single-Valued Field (Other)
 ;;^DIST(.403,.40403,40,2,40,0)
 ;;=^.4032PI^.404032^1
 ;;^DIST(.403,.40403,40,2,40,.404032,0)
 ;;=.404032^1^1,1^e
 ;;^DIST(.403,.40403,40,3,0)
 ;;=21^^3,17^^^1^15,60
 ;;^DIST(.403,.40403,40,3,1)
 ;;=Multiple-Valued Field (Other)
 ;;^DIST(.403,.40403,40,3,40,0)
 ;;=^.4032PI^.404033^1
 ;;^DIST(.403,.40403,40,3,40,.404033,0)
 ;;=.404033^1^1,1^e
 ;;^DIST(.403,.40403,40,4,0)
 ;;=31^^3,17^^^1^13,60

DINIT0F1
DINIT0F1 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F2 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.403,.40403,40,4,1)
 ;;=Word Processing Field (Other)
 ;;^DIST(.403,.40403,40,4,40,0)
 ;;=^.4032PI^.404034^1
 ;;^DIST(.403,.40403,40,4,40,.404034,0)
 ;;=.404034^1^1,1^e
 ;;^DIST(.403,.40404,0)
 ;;=DDGF FIELD FORM ONLY^^^0^2930510^2941123.1312^^.404^0^0^1
 ;;^DIST(.403,.40404,40,0)
 ;;=^.4031I^3^3
 ;;^DIST(.403,.40404,40,1,0)
 ;;=1^^1,1^^^1^16,77
 ;;^DIST(.403,.40404,40,1,1)
 ;;=Form Only Field
 ;;^DIST(.403,.40404,40,1,40,0)
 ;;=^.4032PI^.404041^1
 ;;^DIST(.403,.40404,40,1,40,.404041,0)
 ;;=.404041^1^1,1^e
 ;;^DIST(.403,.40404,40,2,0)
 ;;=11^^3,3^^^1^15,75
 ;;^DIST(.403,.40404,40,2,1)
 ;;=Other Form Only Field Params
 ;;^DIST(.403,.40404,40,2,40,0)
 ;;=^.4032PI^.404042^1
 ;;^DIST(.403,.40404,40,2,40,.404042,0)
 ;;=.404042^1^1,1^e
 ;;^DIST(.403,.40404,40,3,0)
 ;;=21^^3,3^^^1^15,75
 ;;^DIST(.403,.40404,40,3,1)
 ;;=Other Parameters
 ;;^DIST(.403,.40404,40,3,40,0)
 ;;=^.4032PI^.404032^1
 ;;^DIST(.403,.40404,40,3,40,.404032,0)
 ;;=.404032^1^1,1^e
 ;;^DIST(.403,.40405,0)
 ;;=DDGF FIELD COMPUTED^^^0^2930916^2941123.1311^^.404^0^0^1
 ;;^DIST(.403,.40405,40,0)
 ;;=^.4031I^2^2
 ;;^DIST(.403,.40405,40,1,0)
 ;;=1^^1,2^^^1^12,76
 ;;^DIST(.403,.40405,40,1,1)
 ;;=Computed Field
 ;;^DIST(.403,.40405,40,1,40,0)
 ;;=^.4032PI^.404051^1
 ;;^DIST(.403,.40405,40,1,40,.404051,0)
 ;;=.404051^1^1,1^e
 ;;^DIST(.403,.40405,40,2,0)
 ;;=11^^3,16^^^1^11,63
 ;;^DIST(.403,.40405,40,2,1)
 ;;=Other Parameters
 ;;^DIST(.403,.40405,40,2,40,0)
 ;;=^.4032PI^.404052^1
 ;;^DIST(.403,.40405,40,2,40,.404052,0)
 ;;=.404052^1^1,3^e
 ;;^DIST(.403,.40406,0)
 ;;=DDGF BLOCK ADD^^^0^2930413^2941115.1052^^.404^0^1^1
 ;;^DIST(.403,.40406,40,0)
 ;;=^.4031I^3^3
 ;;^DIST(.403,.40406,40,1,0)
 ;;=1^^3,9^^^1^7,65
 ;;^DIST(.403,.40406,40,1,1)
 ;;=Add a New Block
 ;;^DIST(.403,.40406,40,1,40,0)
 ;;=^.4032PI^.404061^1
 ;;^DIST(.403,.40406,40,1,40,.404061,0)
 ;;=.404061^1^1,1^e
 ;;^DIST(.403,.40406,40,2,0)
 ;;=11^^6,12^^^1^11,61
 ;;^DIST(.403,.40406,40,2,1)
 ;;=Add a New Block to Page
 ;;^DIST(.403,.40406,40,2,40,0)
 ;;=^.4032PI^.404062^1
 ;;^DIST(.403,.40406,40,2,40,.404062,0)
 ;;=.404062^1^1,1^e
 ;;^DIST(.403,.40406,40,3,0)
 ;;=21^^6,17^^^1^13,57
 ;;^DIST(.403,.40406,40,3,1)
 ;;=Duplicate Block Message
 ;;^DIST(.403,.40406,40,3,40,0)
 ;;=^.4032PI^.404063^1
 ;;^DIST(.403,.40406,40,3,40,.404063,0)
 ;;=.404063^1^1,1^e
 ;;^DIST(.403,.40407,0)
 ;;=DDGF BLOCK DELETE^^^0^2930809^2940628^^.404^0^1^1
 ;;^DIST(.403,.40407,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40407,40,1,0)
 ;;=1^^5,9^^^1^11,62
 ;;^DIST(.403,.40407,40,1,1)
 ;;=Page 1
 ;;^DIST(.403,.40407,40,1,40,0)
 ;;=^.4032PI^.404071^1
 ;;^DIST(.403,.40407,40,1,40,.404071,0)
 ;;=.404071^1^3,3^e
 ;;^DIST(.403,.40408,0)
 ;;=DDGF HEADER BLOCK SELECT^^^0^2930504^2940928.1204^^.404^0^1^1
 ;;^DIST(.403,.40408,40,0)
 ;;=^.4031I^1^1
 ;;^DIST(.403,.40408,40,1,0)
 ;;=1^^4,5^^^1^8,68
 ;;^DIST(.403,.40408,40,1,1)
 ;;=Add a New Header Block
 ;;^DIST(.403,.40408,40,1,40,0)
 ;;=^.4032PI^.404081^1
 ;;^DIST(.403,.40408,40,1,40,.404081,0)
 ;;=.404081^1^1,1^e

DINIT0F2
DINIT0F2 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F3 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.403011,0)
 ;;=DDGF BLOCK EDIT 1^.4032
 ;;^DIST(.404,.403011,11)
 ;;=I $$GET^DDSVAL(DIE,.DA,3)="d" D UNED^DDSUTL("DISABLE NAVIGATION","DDGF BLOCK EDIT 2","",1)
 ;;^DIST(.404,.403011,40,0)
 ;;=^.4044I^10^8
 ;;^DIST(.404,.403011,40,1,0)
 ;;=1^ Block Properties Stored in FORM File ^1
 ;;^DIST(.404,.403011,40,1,2)
 ;;=^^1,20^1
 ;;^DIST(.404,.403011,40,2,0)
 ;;=3^BLOCK ORDER^3
 ;;^DIST(.404,.403011,40,2,1)
 ;;=1
 ;;^DIST(.404,.403011,40,2,2)
 ;;=3,69^4^3,56
 ;;^DIST(.404,.403011,40,2,4)
 ;;=1
 ;;^DIST(.404,.403011,40,3,0)
 ;;=4^TYPE OF BLOCK^3
 ;;^DIST(.404,.403011,40,3,1)
 ;;=3
 ;;^DIST(.404,.403011,40,3,2)
 ;;=4,18^7^4,3
 ;;^DIST(.404,.403011,40,3,4)
 ;;=1
 ;;^DIST(.404,.403011,40,3,13)
 ;;=D:X="d" PUT^DDSVAL(.404,$$GET^DDSVAL(DIE,.DA,.01),2,"") D UNED^DDSUTL("DISABLE NAVIGATION","DDGF BLOCK EDIT 2","",$E(1,X="d"))
 ;;^DIST(.404,.403011,40,5,0)
 ;;=6^POINTER LINK^3
 ;;^DIST(.404,.403011,40,5,1)
 ;;=4
 ;;^DIST(.404,.403011,40,5,2)
 ;;=6,18^57^6,4
 ;;^DIST(.404,.403011,40,6,0)
 ;;=2^BLOCK NAME^3
 ;;^DIST(.404,.403011,40,6,1)
 ;;=.01
 ;;^DIST(.404,.403011,40,6,2)
 ;;=3,18^30^3,6
 ;;^DIST(.404,.403011,40,8,0)
 ;;=7^PRE ACTION^3
 ;;^DIST(.404,.403011,40,8,1)
 ;;=11
 ;;^DIST(.404,.403011,40,8,2)
 ;;=7,18^57^7,6
 ;;^DIST(.404,.403011,40,9,0)
 ;;=9^POST ACTION^3
 ;;^DIST(.404,.403011,40,9,1)
 ;;=12
 ;;^DIST(.404,.403011,40,9,2)
 ;;=8,18^57^8,5
 ;;^DIST(.404,.403011,40,10,0)
 ;;=5^OTHER PARAMETERS...^2
 ;;^DIST(.404,.403011,40,10,2)
 ;;=4,69^1^4,49^1
 ;;^DIST(.404,.403011,40,10,7)
 ;;=^11
 ;;^DIST(.404,.403011,40,10,20)
 ;;=F^^0:0
 ;;^DIST(.404,.403011,40,10,21,0)
 ;;=^^1^1^2940928^
 ;;^DIST(.404,.403011,40,10,21,1,0)
 ;;=Press <RET> to edit additional properties of the block
 ;;^DIST(.404,.403012,0)
 ;;=DDGF BLOCK EDIT 2^.404
 ;;^DIST(.404,.403012,40,0)
 ;;=^.4044I^7^7
 ;;^DIST(.404,.403012,40,1,0)
 ;;=1^----------------- Block Properties Stored in BLOCK File ------------------^1
 ;;^DIST(.404,.403012,40,1,2)
 ;;=^^1,2^1
 ;;^DIST(.404,.403012,40,2,0)
 ;;=2^NAME^2
 ;;^DIST(.404,.403012,40,2,2)
 ;;=3,16^30^3,10
 ;;^DIST(.404,.403012,40,2,3)
 ;;=!M
 ;;^DIST(.404,.403012,40,2,3.1)
 ;;=S Y=DDGFBKNO
 ;;^DIST(.404,.403012,40,2,20)
 ;;=DD^^.404,.01
 ;;^DIST(.404,.403012,40,2,23)
 ;;=S DDGFBKNN=X
 ;;^DIST(.404,.403012,40,3,0)
 ;;=3^DESCRIPTION (WP)^3
 ;;^DIST(.404,.403012,40,3,1)
 ;;=15
 ;;^DIST(.404,.403012,40,3,2)
 ;;=3,69^1^3,51
 ;;^DIST(.404,.403012,40,4,0)
 ;;=4^DD NUMBER^3
 ;;^DIST(.404,.403012,40,4,1)
 ;;=1
 ;;^DIST(.404,.403012,40,4,2)
 ;;=4,16^16^4,5
 ;;^DIST(.404,.403012,40,5,0)
 ;;=5^DISABLE NAVIGATION^3
 ;;^DIST(.404,.403012,40,5,1)
 ;;=2
 ;;^DIST(.404,.403012,40,5,2)
 ;;=4,69^5^4,49
 ;;^DIST(.404,.403012,40,6,0)
 ;;=6^PRE ACTION^3
 ;;^DIST(.404,.403012,40,6,1)
 ;;=11
 ;;^DIST(.404,.403012,40,6,2)
 ;;=6,16^59^6,4
 ;;^DIST(.404,.403012,40,7,0)
 ;;=7^POST ACTION^3
 ;;^DIST(.404,.403012,40,7,1)
 ;;=12
 ;;^DIST(.404,.403012,40,7,2)
 ;;=7,16^59^7,3
 ;;^DIST(.404,.403013,0)
 ;;=DDGF BLOCK EDIT OTHER^.4032
 ;;^DIST(.404,.403013,11)
 ;;=I $$GET^DDSVAL(DIE,.DA,"REPLICATION")<2 N DDGFZ F DDGFZ="INDEX","INITIAL POSITION","DISALLOW LAYGO","FIELD FOR SELECTION" D UNED^DDSUTL(DDGFZ,"","",1)
 ;;^DIST(.404,.403013,40,0)
 ;;=^.4044I^8^8
 ;;^DIST(.404,.403013,40,1,0)
 ;;=1^ Other Block Parameters ^1
 ;;^DIST(.404,.403013,40,1,2)
 ;;=^^1,16
 ;;^DIST(.404,.403013,40,2,0)
 ;;=2^BLOCK COORDINATE^2
 ;;^DIST(.404,.403013,40,2,2)
 ;;=3,24^7^3,6
 ;;^DIST(.404,.403013,40,2,3)
 ;;=!M
 ;;^DIST(.404,.403013,40,2,3.1)
 ;;=S Y=DDGFBKCO
 ;;^DIST(.404,.403013,40,2,4)
 ;;=1
 ;;^DIST(.404,.403013,40,2,20)
 ;;=DD^^.4032,2
 ;;^DIST(.404,.403013,40,2,23)
 ;;=S DDGFBKCN=X
 ;;^DIST(.404,.403013,40,3,0)
 ;;=3^Parameters for Repeating Blocks^1
 ;;^DIST(.404,.403013,40,3,2)
 ;;=^^5,3
 ;;^DIST(.404,.403013,40,4,0)
 ;;=4^REPLICATION^3
 ;;^DIST(.404,.403013,40,4,1)
 ;;=5
 ;;^DIST(.404,.403013,40,4,2)
 ;;=7,24^3^7,11
 ;;^DIST(.404,.403013,40,4,13)
 ;;=Q:DDSOLD>1&(X>1)  N DDGFZ F DDGFZ="INDEX","INITIAL POSITION","DISALLOW LAYGO","FIELD FOR SELECTION" D UNED^DDSUTL(DDGFZ,"","",X<2) D:X<2 PUT^DDSVAL(DIE,.DA,DDGFZ)
 ;;^DIST(.404,.403013,40,5,0)
 ;;=5^INDEX^3
 ;;^DIST(.404,.403013,40,5,1)
 ;;=6
 ;;^DIST(.404,.403013,40,5,2)
 ;;=8,24^30^8,17
 ;;^DIST(.404,.403013,40,6,0)
 ;;=6^INITIAL POSITION^3
 ;;^DIST(.404,.403013,40,6,1)
 ;;=7
 ;;^DIST(.404,.403013,40,6,2)
 ;;=9,24^5^9,6
 ;;^DIST(.404,.403013,40,7,0)
 ;;=7^DISALLOW LAYGO^3
 ;;^DIST(.404,.403013,40,7,1)
 ;;=8

DINIT0F3
DINIT0F3 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F4 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.403013,40,7,2)
 ;;=10,24^3^10,8
 ;;^DIST(.404,.403013,40,8,0)
 ;;=8^FIELD FOR SELECTION^3
 ;;^DIST(.404,.403013,40,8,1)
 ;;=9
 ;;^DIST(.404,.403013,40,8,2)
 ;;=11,24^30^11,3
 ;;^DIST(.404,.403021,0)
 ;;=DDGF PAGE ADD^.4031
 ;;^DIST(.404,.403021,40,0)
 ;;=^.4044I^1^1
 ;;^DIST(.404,.403021,40,1,0)
 ;;=1^NEW PAGE NUMBER^2
 ;;^DIST(.404,.403021,40,1,2)
 ;;=3,20^5^3,3
 ;;^DIST(.404,.403021,40,1,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.403021,40,1,20)
 ;;=DD^^.4031,.01
 ;;^DIST(.404,.403021,40,1,23)
 ;;=S DDGFPNUM=X
 ;;^DIST(.404,.403022,0)
 ;;=DDGF PAGE ADD ARE YOU SURE^.4031
 ;;^DIST(.404,.403022,40,0)
 ;;=^.4044I^2^2
 ;;^DIST(.404,.403022,40,1,0)
 ;;=1^!M^1
 ;;^DIST(.404,.403022,40,1,.1)
 ;;=S Y="Are you adding Page "_DDGFPNUM
 ;;^DIST(.404,.403022,40,1,2)
 ;;=^^3,3
 ;;^DIST(.404,.403022,40,2,0)
 ;;=2^as a new page on this form?^2
 ;;^DIST(.404,.403022,40,2,2)
 ;;=4,31^3^4,3^1
 ;;^DIST(.404,.403022,40,2,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.403022,40,2,20)
 ;;=Y
 ;;^DIST(.404,.403022,40,2,23)
 ;;=S DDGFANS=X
 ;;^DIST(.404,.403031,0)
 ;;=DDGF PAGE EDIT^.4031
 ;;^DIST(.404,.403031,40,0)
 ;;=^.4044I^16^13
 ;;^DIST(.404,.403031,40,1,0)
 ;;=1^ Page Properties ^1
 ;;^DIST(.404,.403031,40,1,2)
 ;;=^^1,27
 ;;^DIST(.404,.403031,40,2,0)
 ;;=2^PAGE NUMBER^3
 ;;^DIST(.404,.403031,40,2,1)
 ;;=.01
 ;;^DIST(.404,.403031,40,2,2)
 ;;=3,21^5^3,8
 ;;^DIST(.404,.403031,40,4,0)
 ;;=4^HEADER BLOCK^3
 ;;^DIST(.404,.403031,40,4,1)
 ;;=1
 ;;^DIST(.404,.403031,40,4,2)
 ;;=5,21^30^5,7
 ;;^DIST(.404,.403031,40,5,0)
 ;;=8^NEXT PAGE^3
 ;;^DIST(.404,.403031,40,5,1)
 ;;=3
 ;;^DIST(.404,.403031,40,5,2)
 ;;=9,21^5^9,10
 ;;^DIST(.404,.403031,40,6,0)
 ;;=9^PREVIOUS PAGE^3
 ;;^DIST(.404,.403031,40,6,1)
 ;;=4
 ;;^DIST(.404,.403031,40,6,2)
 ;;=10,21^5^10,6
 ;;^DIST(.404,.403031,40,7,0)
 ;;=12^PRE ACTION^3
 ;;^DIST(.404,.403031,40,7,1)
 ;;=11
 ;;^DIST(.404,.403031,40,7,2)
 ;;=14,21^53^14,9
 ;;^DIST(.404,.403031,40,8,0)
 ;;=13^POST ACTION^3
 ;;^DIST(.404,.403031,40,8,1)
 ;;=12
 ;;^DIST(.404,.403031,40,8,2)
 ;;=15,21^53^15,8
 ;;^DIST(.404,.403031,40,9,0)
 ;;=11^DESCRIPTION (WP)^3
 ;;^DIST(.404,.403031,40,9,1)
 ;;=15
 ;;^DIST(.404,.403031,40,9,2)
 ;;=13,21^1^13,3
 ;;^DIST(.404,.403031,40,12,0)
 ;;=10^PARENT FIELD^3
 ;;^DIST(.404,.403031,40,12,1)
 ;;=8
 ;;^DIST(.404,.403031,40,12,2)
 ;;=11,21^53^11,7
 ;;^DIST(.404,.403031,40,13,0)
 ;;=6^IS THIS A POP UP PAGE?^2
 ;;^DIST(.404,.403031,40,13,2)
 ;;=7,67^3^7,44^1
 ;;^DIST(.404,.403031,40,13,3)
 ;;=!M
 ;;^DIST(.404,.403031,40,13,3.1)
 ;;=S:$G(DDGFLRC)]"" Y=1
 ;;^DIST(.404,.403031,40,13,13)
 ;;=N LRC,PP,NP S LRC="LOWER RIGHT COORDINATE",PP="PREVIOUS PAGE",NP="NEXT PAGE" D:X PUT^DDSVALF(LRC,"","","15,75"):$$GET^DDSVALF(LRC)="" D:'X PUT^DDSVALF(LRC) N PG F PG=NP,PP D UNED^DDSUTL(PG,"","",$E(1,X)) D:X PUT^DDSVAL(DIE,.DA,PG)
 ;;^DIST(.404,.403031,40,13,20)
 ;;=DD^^.4031,5
 ;;^DIST(.404,.403031,40,14,0)
 ;;=5^PAGE COORDINATE^2
 ;;^DIST(.404,.403031,40,14,2)
 ;;=7,21^7^7,4
 ;;^DIST(.404,.403031,40,14,3)
 ;;=!M
 ;;^DIST(.404,.403031,40,14,3.1)
 ;;=S Y=$G(DDGFTLC0)
 ;;^DIST(.404,.403031,40,14,4)
 ;;=1
 ;;^DIST(.404,.403031,40,14,20)
 ;;=DD^^.4031,2
 ;;^DIST(.404,.403031,40,14,23)
 ;;=S DDGFTLC=X
 ;;^DIST(.404,.403031,40,15,0)
 ;;=7^LOWER RIGHT COORDINATE^2
 ;;^DIST(.404,.403031,40,15,2)
 ;;=8,67^7^8,43
 ;;^DIST(.404,.403031,40,15,3)
 ;;=!M
 ;;^DIST(.404,.403031,40,15,3.1)
 ;;=S Y=$G(DDGFLRC0)
 ;;^DIST(.404,.403031,40,15,13)
 ;;=I DDSOLD=""!(X="") D PUT^DDSVALF("IS THIS A POP UP PAGE?","","",$S(X="":"",1:1),"I") N PG,NP,PP S NP="NEXT PAGE",PP="PREVIOUS PAGE" F PG=NP,PP D UNED^DDSUTL(PG,"","",$E(1,X]"")) D:X]"" PUT^DDSVAL(DIE,.DA,PG)
 ;;^DIST(.404,.403031,40,15,20)
 ;;=DD^^.4031,6
 ;;^DIST(.404,.403031,40,15,23)
 ;;=S DDGFLRC=X
 ;;^DIST(.404,.403031,40,16,0)
 ;;=3^PAGE NAME^2
 ;;^DIST(.404,.403031,40,16,2)
 ;;=4,21^30^4,10
 ;;^DIST(.404,.403031,40,16,3)
 ;;=!M
 ;;^DIST(.404,.403031,40,16,3.1)
 ;;=S Y=$G(DDGFPNM0)
 ;;^DIST(.404,.403031,40,16,4)
 ;;=1
 ;;^DIST(.404,.403031,40,16,20)
 ;;=DD^^.4031,7
 ;;^DIST(.404,.403031,40,16,23)
 ;;=S DDGFPNM=X
 ;;^DIST(.404,.403041,0)
 ;;=DDGF PAGE SELECT^.4031
 ;;^DIST(.404,.403041,40,0)
 ;;=^.4044I^1^1
 ;;^DIST(.404,.403041,40,1,0)
 ;;=1^Select PAGE^2
 ;;^DIST(.404,.403041,40,1,2)
 ;;=1,14^30^1,1
 ;;^DIST(.404,.403041,40,1,3)
 ;;=!M
 ;;^DIST(.404,.403041,40,1,3.1)
 ;;=S Y=$P(^DIST(.403,+DDGFFM,40,DDGFPAGE,0),U)
 ;;^DIST(.404,.403041,40,1,12)
 ;;=S DDACT="EX"

DINIT0F4
DINIT0F4 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F5 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.403041,40,1,20)
 ;;=P^^DIST(.403,+DDGFFM,40,:QEAMZF
 ;;^DIST(.404,.403041,40,1,23)
 ;;=S DDGFPAGE=X
 ;;^DIST(.404,.403051,0)
 ;;=DDGF FORM EDIT^.403
 ;;^DIST(.404,.403051,40,0)
 ;;=^.4044I^11^11
 ;;^DIST(.404,.403051,40,1,0)
 ;;=1^ Form Properties ^1
 ;;^DIST(.404,.403051,40,1,2)
 ;;=^^1,29
 ;;^DIST(.404,.403051,40,2,0)
 ;;=2^NAME^3
 ;;^DIST(.404,.403051,40,2,1)
 ;;=.01
 ;;^DIST(.404,.403051,40,2,2)
 ;;=3,20^30^3,14
 ;;^DIST(.404,.403051,40,2,4)
 ;;=1
 ;;^DIST(.404,.403051,40,3,0)
 ;;=4^PRE ACTION^3
 ;;^DIST(.404,.403051,40,3,1)
 ;;=11
 ;;^DIST(.404,.403051,40,3,2)
 ;;=6,20^54^6,8
 ;;^DIST(.404,.403051,40,4,0)
 ;;=5^POST ACTION^3
 ;;^DIST(.404,.403051,40,4,1)
 ;;=12
 ;;^DIST(.404,.403051,40,4,2)
 ;;=7,20^54^7,7
 ;;^DIST(.404,.403051,40,5,0)
 ;;=8^DESCRIPTION^3
 ;;^DIST(.404,.403051,40,5,1)
 ;;=15
 ;;^DIST(.404,.403051,40,5,2)
 ;;=11,20^1^11,7
 ;;^DIST(.404,.403051,40,6,0)
 ;;=6^DATA VALIDATION^3
 ;;^DIST(.404,.403051,40,6,1)
 ;;=20
 ;;^DIST(.404,.403051,40,6,2)
 ;;=8,20^54^8,3
 ;;^DIST(.404,.403051,40,7,0)
 ;;=9^RECORD SELECTION PAGE^3
 ;;^DIST(.404,.403051,40,7,1)
 ;;=21
 ;;^DIST(.404,.403051,40,7,2)
 ;;=11,69^5^11,46
 ;;^DIST(.404,.403051,40,8,0)
 ;;=7^POST SAVE^3
 ;;^DIST(.404,.403051,40,8,1)
 ;;=14
 ;;^DIST(.404,.403051,40,8,2)
 ;;=9,20^54^9,9
 ;;^DIST(.404,.403051,40,9,0)
 ;;=3^TITLE^3
 ;;^DIST(.404,.403051,40,9,1)
 ;;=6
 ;;^DIST(.404,.403051,40,9,2)
 ;;=4,20^50^4,13
 ;;^DIST(.404,.403051,40,10,0)
 ;;=10^READ ACCESS^3
 ;;^DIST(.404,.403051,40,10,1)
 ;;=1
 ;;^DIST(.404,.403051,40,10,2)
 ;;=13,20^15^13,7
 ;;^DIST(.404,.403051,40,11,0)
 ;;=11^WRITE ACCESS^3
 ;;^DIST(.404,.403051,40,11,1)
 ;;=2
 ;;^DIST(.404,.403051,40,11,2)
 ;;=14,20^15^14,6
 ;;^DIST(.404,.403061,0)
 ;;=DDGF HEADER BLOCK EDIT^.4031
 ;;^DIST(.404,.403061,40,0)
 ;;=^.4044I^2^2
 ;;^DIST(.404,.403061,40,1,0)
 ;;=2^HEADER BLOCK^3
 ;;^DIST(.404,.403061,40,1,1)
 ;;=1
 ;;^DIST(.404,.403061,40,1,2)
 ;;=3,17^30^3,3
 ;;^DIST(.404,.403061,40,1,13)
 ;;=D:X]"" PUT^DDSVALF("NAME","DDGF BLOCK EDIT 2","",DDSEXT,"I")
 ;;^DIST(.404,.403061,40,1,14)
 ;;=D HBVAL^DDGFU
 ;;^DIST(.404,.403061,40,2,0)
 ;;=1^ Edit Header Block Parameters ^1
 ;;^DIST(.404,.403061,40,2,2)
 ;;=^^1,24
 ;;^DIST(.404,.404011,0)
 ;;=DDGF FIELD ADD
 ;;^DIST(.404,.404011,40,0)
 ;;=^.4044I^3^3
 ;;^DIST(.404,.404011,40,1,0)
 ;;=1^Select BLOCK^2
 ;;^DIST(.404,.404011,40,1,2)
 ;;=1,15^30^1,1
 ;;^DIST(.404,.404011,40,1,3)
 ;;=!M
 ;;^DIST(.404,.404011,40,1,3.1)
 ;;=N X,DA,DIC S DA(2)=+DDGFFM,DA(1)=+DDGFPG,X=" ",DIC="^DIST(.403,"_DA(2)_",""40"","_DA(1)_",""40"",",DIC(0)="M" D ^DIC S Y=$S(Y=-1:"",1:"`"_+Y) I Y="",$P($G(^DIST(.403,+DDGFFM,40,+DDGFPG,40,0)),U,4)=1 S Y=+$O(^(0)),Y=$S(Y:"`"_Y,1:"")
 ;;^DIST(.404,.404011,40,1,13)
 ;;=I X]"" D PUT^DDSVALF("FIELD ORDER","","",$O(^DIST(.404,X,40,"B",""),-1)+1\1) D:$D(DUZ)#2 RECALL^DILFD(.4032,X_","_+DDGFPG_","_+DDGFFM_",",DUZ),RECALL^DILFD(.404,X_",",DUZ)
 ;;^DIST(.404,.404011,40,1,20)
 ;;=P^^DIST(.403,+DDGFFM,40,+DDGFPG,40,:QEAFMZ
 ;;^DIST(.404,.404011,40,1,23)
 ;;=S DDGFBLCK=X
 ;;^DIST(.404,.404011,40,2,0)
 ;;=2^FIELD ORDER^2
 ;;^DIST(.404,.404011,40,2,2)
 ;;=2,15^4^2,2
 ;;^DIST(.404,.404011,40,2,3)
 ;;=!M
 ;;^DIST(.404,.404011,40,2,3.1)
 ;;=N V S V=$$GET^DDSVALF("BLOCK") I V]"" S Y=$O(^DIST(.404,V,40,"B",""),-1)+1\1
 ;;^DIST(.404,.404011,40,2,20)
 ;;=N^^0:99.9:1
 ;;^DIST(.404,.404011,40,2,21,0)
 ;;=^^1^1^2940630^
 ;;^DIST(.404,.404011,40,2,21,1,0)
 ;;=This must be a number not already used
 ;;^DIST(.404,.404011,40,2,22)
 ;;=N V S V=$$GET^DDSVALF("BLOCK") I V]"",$O(^DIST(.404,V,40,"B",X,""))]"" K X
 ;;^DIST(.404,.404011,40,2,23)
 ;;=S DDGFFORD=X
 ;;^DIST(.404,.404011,40,3,0)
 ;;=3^FIELD TYPE^2
 ;;^DIST(.404,.404011,40,3,2)
 ;;=3,15^30^3,3
 ;;^DIST(.404,.404011,40,3,3)
 ;;=DATA DICTIONARY
 ;;^DIST(.404,.404011,40,3,20)
 ;;=DD^^.4044,2
 ;;^DIST(.404,.404011,40,3,23)
 ;;=S DDGFTYPE=X
 ;;^DIST(.404,.404021,0)
 ;;=DDGF FIELD CAPTION ONLY^.4044
 ;;^DIST(.404,.404021,40,0)
 ;;=^.4044I^9^6
 ;;^DIST(.404,.404021,40,1,0)
 ;;=1^ Caption-Only Field Properties ^1
 ;;^DIST(.404,.404021,40,1,2)
 ;;=^^1,22
 ;;^DIST(.404,.404021,40,2,0)
 ;;=2^FIELD ORDER^3
 ;;^DIST(.404,.404021,40,2,1)
 ;;=.01
 ;;^DIST(.404,.404021,40,2,2)
 ;;=3,21^4^3,8
 ;;^DIST(.404,.404021,40,6,0)
 ;;=3^CAPTION^2
 ;;^DIST(.404,.404021,40,6,2)
 ;;=4,21^50^4,12
 ;;^DIST(.404,.404021,40,6,3)
 ;;=!M
 ;;^DIST(.404,.404021,40,6,3.1)
 ;;=S Y=DDGFCAP0
 ;;^DIST(.404,.404021,40,6,4)
 ;;=1

DINIT0F5
DINIT0F5 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 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
 Q
ENTRY ;
 ;;^DIST(.404,.404021,40,6,13)
 ;;=D:DDSOLD="!M" PUT^DDSVAL(.4044,.DA,1.1,"")
 ;;^DIST(.404,.404021,40,6,20)
 ;;=DD^^.4044,1
 ;;^DIST(.404,.404021,40,6,23)
 ;;=S DDGFCAP=X
 ;;^DIST(.404,.404021,40,7,0)
 ;;=5^EXECUTABLE CAPTION^3
 ;;^DIST(.404,.404021,40,7,1)
 ;;=1.1
 ;;^DIST(.404,.404021,40,7,2)
 ;;=7,21^50^7,1
 ;;^DIST(.404,.404021,40,7,13)
 ;;=D PUT^DDSVALF("CAPTION","","",$S(X="":"",1:"!M"))
 ;;^DIST(.404,.404021,40,8,0)
 ;;=6^CAPTION COORDINATE^2
 ;;^DIST(.404,.404021,40,8,2)
 ;;=8,21^7^8,1
 ;;^DIST(.404,.404021,40,8,3)
 ;;=!M
 ;;^DIST(.404,.404021,40,8,3.1)
 ;;=S Y=DDGFCC0
 ;;^DIST(.404,.404021,40,8,4)
 ;;=1
 ;;^DIST(.404,.404021,40,8,20)
 ;;=DD^^.4044,5.1
 ;;^DIST(.404,.404021,40,8,23)
 ;;=S DDGFCC=X
 ;;^DIST(.404,.404021,40,9,0)
 ;;=4^UNIQUE NAME^3
 ;;^DIST(.404,.404021,40,9,1)
 ;;=3.1
 ;;^DIST(.404,.404021,40,9,2)
 ;;=5,21^50^5,8
 ;;^DIST(.404,.404031,0)
 ;;=DDGF FIELD DD^.4044
 ;;^DIST(.404,.404031,40,0)
 ;;=^.4044I^17^14
 ;;^DIST(.404,.404031,40,1,0)
 ;;=1^ Data Dictionary Field Properties ^1
 ;;^DIST(.404,.404031,40,1,2)
 ;;=^^1,22
 ;;^DIST(.404,.404031,40,2,0)
 ;;=2^FIELD ORDER^3
 ;;^DIST(.404,.404031,40,2,1)
 ;;=.01
 ;;^DIST(.404,.404031,40,2,2)
 ;;=3,26^4^3,13
 ;;^DIST(.404,.404031,40,3,0)
 ;;=3^FIELD^3
 ;;^DIST(.404,.404031,40,3,1)
 ;;=4
 ;;^DIST(.404,.404031,40,3,2)
 ;;=3,66^10^3,59
 ;;^DIST(.404,.404031,40,3,4)
 ;;=1
 ;;^DIST(.404,.404031,40,3,13)
 ;;=D POSTCH1^DDGFU
 ;;^DIST(.404,.404031,40,5,0)
 ;;=8^DEFAULT^3
 ;;^DIST(.404,.404031,40,5,1)
 ;;=6
 ;;^DIST(.404,.404031,40,5,2)
 ;;=8,26^50^8,17
 ;;^DIST(.404,.404031,40,5,13)
 ;;=D:DDSOLD="!M" PUT^DDSVAL(.4044,.DA,6.01,"")
 ;;^DIST(.404,.404031,40,7,0)
 ;;=11^BRANCHING LOGIC^3
 ;;^DIST(.404,.404031,40,7,1)
 ;;=10
 ;;^DIST(.404,.404031,40,7,2)
 ;;=12,26^50^12,9
 ;;^DIST(.404,.404031,40,8,0)
 ;;=12^PRE ACTION^3
 ;;^DIST(.404,.404031,40,8,1)
 ;;=11
 ;;^DIST(.404,.404031,40,8,2)
 ;;=13,26^50^13,14
 ;;^DIST(.404,.404031,40,9,0)
 ;;=13^POST ACTION^3
 ;;^DIST(.404,.404031,40,9,1)
 ;;=12
 ;;^DIST(.404,.404031,40,9,2)
 ;;=14,26^50^14,13
 ;;^DIST(.404,.404031,40,10,0)
 ;;=14^POST ACTION ON CHANGE^3
 ;;^DIST(.404,.404031,40,10,1)
 ;;=13
 ;;^DIST(.404,.404031,40,10,2)
 ;;=15,26^50^15,3
 ;;^DIST(.404,.404031,40,12,0)
 ;;=10^EXECUTABLE DEFAULT^3
 ;;^DIST(.404,.404031,40,12,1)
 ;;=6.01
 ;;^DIST(.404,.404031,40,12,2)
 ;;=10,26^50^10,6
 ;;^DIST(.404,.404031,40,12,13)
 ;;=D PUT^DDSVAL(.4044,.DA,6,$S(X="":"",1:"!M"))
 ;;^DIST(.404,.404031,40,13,0)
 ;;=4^OTHER PARAMETERS...^2
 ;;^DIST(.404,.404031,40,13,2)
 ;;=4,26^1^4,6^1
 ;;^DIST(.404,.404031,40,13,10)
 ;;=N DDGFFLD,DDGFSUB S DDSSTACK=11,DDGFFLD=$$GET^DDSVAL(.4044,.DA,4) I DDGFFLD S DDGFSUB=+$P($G(^DD(DDGFDD,DDGFFLD,0)),U,2) S:DDGFSUB DDSSTACK=$S(DDGFSUB_$P($G(^DD(DDGFSUB,.01,0)),U,2)'["W":21,1:31)
 ;;^DIST(.404,.404031,40,13,20)
 ;;=F^^0:0
 ;;^DIST(.404,.404031,40,13,21,0)
 ;;=^^1^1^2940928^
 ;;^DIST(.404,.404031,40,13,21,1,0)
 ;;=Press <RET> to edit additional properties of this Data Dictionary field
 ;;^DIST(.404,.404031,40,14,0)
 ;;=7^CAPTION^2
 ;;^DIST(.404,.404031,40,14,2)
 ;;=7,26^50^7,17
 ;;^DIST(.404,.404031,40,14,3)
 ;;=!M
 ;;^DIST(.404,.404031,40,14,3.1)
 ;;=S Y=DDGFCAP0
 ;;^DIST(.404,.404031,40,14,13)
 ;;=D DDCAP^DDGFU
 ;;^DIST(.404,.404031,40,14,20)
 ;;=DD^^.4044,1
 ;;^DIST(.404,.404031,40,14,23)
 ;;=S DDGFCAP=X
 ;;^DIST(.404,.404031,40,15,0)
 ;;=5^SUPPRESS COLON AFTER CAPTION?^2
 ;;^DIST(.404,.404031,40,15,2)
 ;;=4,66^3^4,36^1
 ;;^DIST(.404,.404031,40,15,3)
 ;;=!M
 ;;^DIST(.404,.404031,40,15,3.1)
 ;;=S Y=DDGFSUP0
 ;;^DIST(.404,.404031,40,15,20)
 ;;=DD^^.4044,5.2
 ;;^DIST(.404,.404031,40,15,23)
 ;;=S DDGFSUP=X
 ;;^DIST(.404,.404031,40,16,0)
 ;;=6^UNIQUE NAME^3
 ;;^DIST(.404,.404031,40,16,1)
 ;;=3.1
 ;;^DIST(.404,.404031,40,16,2)
 ;;=5,26^50^5,13
 ;;^DIST(.404,.404031,40,17,0)
 ;;=9^EXECUTABLE CAPTION^3
 ;;^DIST(.404,.404031,40,17,1)
 ;;=1.1
 ;;^DIST(.404,.404031,40,17,2)
 ;;=9,26^50^9,6
 ;;^DIST(.404,.404031,40,17,13)
 ;;=D PUT^DDSVALF("CAPTION","","",$S(X="":"",1:"!M"),"I")
 ;;^DIST(.404,.404032,0)
 ;;=DDGF FIELD DD OTHER SINGLE^.4044
 ;;^DIST(.404,.404032,40,0)
 ;;=^.4044I^13^10
 ;;^DIST(.404,.404032,40,1,0)
 ;;=1^ Other Parameters ^1
 ;;^DIST(.404,.404032,40,1,2)
 ;;=^^1,27
 ;;^DIST(.404,.404032,40,2,0)
 ;;=2^REQUIRED^3
 ;;^DIST(.404,.404032,40,2,1)
 ;;=6.1
 ;;^DIST(.404,.404032,40,2,2)
 ;;=3,23^3^3,13
 ;;^DIST(.404,.404032,40,3,0)
 ;;=4^DISABLE EDITING^3
 ;;^DIST(.404,.404032,40,3,1)
 ;;=6.4

DINIT0F6
DINIT0F6 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F7 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.404032,40,3,2)
 ;;=4,23^9^4,6
 ;;^DIST(.404,.404032,40,7,0)
 ;;=7^DATA LENGTH^2
 ;;^DIST(.404,.404032,40,7,2)
 ;;=7,23^3^7,10
 ;;^DIST(.404,.404032,40,7,3)
 ;;=!M
 ;;^DIST(.404,.404032,40,7,3.1)
 ;;=S Y=$G(DDGFDL0)
 ;;^DIST(.404,.404032,40,7,4)
 ;;=1
 ;;^DIST(.404,.404032,40,7,20)
 ;;=DD^^.4044,4.2
 ;;^DIST(.404,.404032,40,7,23)
 ;;=S DDGFDL=X
 ;;^DIST(.404,.404032,40,8,0)
 ;;=8^CAPTION COORDINATE^2
 ;;^DIST(.404,.404032,40,8,2)
 ;;=8,23^7^8,3
 ;;^DIST(.404,.404032,40,8,3)
 ;;=!M
 ;;^DIST(.404,.404032,40,8,3.1)
 ;;=S Y=$G(DDGFCC0)
 ;;^DIST(.404,.404032,40,8,20)
 ;;=DD^^.4044,5.1
 ;;^DIST(.404,.404032,40,8,23)
 ;;=S DDGFCC=X
 ;;^DIST(.404,.404032,40,9,0)
 ;;=9^DATA COORDINATE^2
 ;;^DIST(.404,.404032,40,9,2)
 ;;=9,23^7^9,6
 ;;^DIST(.404,.404032,40,9,3)
 ;;=!M
 ;;^DIST(.404,.404032,40,9,3.1)
 ;;=S Y=$G(DDGFDC0)
 ;;^DIST(.404,.404032,40,9,4)
 ;;=1
 ;;^DIST(.404,.404032,40,9,20)
 ;;=DD^^.4044,4.1
 ;;^DIST(.404,.404032,40,9,23)
 ;;=S DDGFDC=X
 ;;^DIST(.404,.404032,40,10,0)
 ;;=10^DATA VALIDATION^3
 ;;^DIST(.404,.404032,40,10,1)
 ;;=14
 ;;^DIST(.404,.404032,40,10,2)
 ;;=11,23^49^11,6
 ;;^DIST(.404,.404032,40,11,0)
 ;;=5^RIGHT JUSTIFY^3
 ;;^DIST(.404,.404032,40,11,1)
 ;;=6.3
 ;;^DIST(.404,.404032,40,11,2)
 ;;=4,52^3^4,37
 ;;^DIST(.404,.404032,40,12,0)
 ;;=6^SUB PAGE LINK^3
 ;;^DIST(.404,.404032,40,12,1)
 ;;=8
 ;;^DIST(.404,.404032,40,12,2)
 ;;=5,23^5^5,8
 ;;^DIST(.404,.404032,40,13,0)
 ;;=3^DISPLAY GROUP^3
 ;;^DIST(.404,.404032,40,13,1)
 ;;=3
 ;;^DIST(.404,.404032,40,13,2)
 ;;=3,52^20^3,37
 ;;^DIST(.404,.404033,0)
 ;;=DDGF FIELD DD OTHER MULTIPLE^.4044
 ;;^DIST(.404,.404033,40,0)
 ;;=^.4044I^11^8
 ;;^DIST(.404,.404033,40,1,0)
 ;;=1^ Other Parameters ^1
 ;;^DIST(.404,.404033,40,1,2)
 ;;=^^1,14^1
 ;;^DIST(.404,.404033,40,2,0)
 ;;=2^SUB PAGE LINK^3
 ;;^DIST(.404,.404033,40,2,1)
 ;;=8
 ;;^DIST(.404,.404033,40,2,2)
 ;;=3,23^3^3,8
 ;;^DIST(.404,.404033,40,3,0)
 ;;=3^DISALLOW LAYGO^3
 ;;^DIST(.404,.404033,40,3,1)
 ;;=6.5
 ;;^DIST(.404,.404033,40,3,2)
 ;;=4,23^3^4,7
 ;;^DIST(.404,.404033,40,7,0)
 ;;=7^CAPTION COORDINATE^2
 ;;^DIST(.404,.404033,40,7,2)
 ;;=10,23^7^10,3
 ;;^DIST(.404,.404033,40,7,3)
 ;;=!M
 ;;^DIST(.404,.404033,40,7,3.1)
 ;;=S Y=$G(DDGFCC0)
 ;;^DIST(.404,.404033,40,7,20)
 ;;=DD^^.4044,5.1
 ;;^DIST(.404,.404033,40,7,23)
 ;;=S DDGFCC=X
 ;;^DIST(.404,.404033,40,8,0)
 ;;=8^DATA COORDINATE^2
 ;;^DIST(.404,.404033,40,8,2)
 ;;=11,23^7^11,6
 ;;^DIST(.404,.404033,40,8,3)
 ;;=!M
 ;;^DIST(.404,.404033,40,8,3.1)
 ;;=S Y=$G(DDGFDC0)
 ;;^DIST(.404,.404033,40,8,4)
 ;;=1
 ;;^DIST(.404,.404033,40,8,20)
 ;;=DD^^.4044,4.1
 ;;^DIST(.404,.404033,40,8,23)
 ;;=S DDGFDC=X
 ;;^DIST(.404,.404033,40,9,0)
 ;;=6^DATA LENGTH^2
 ;;^DIST(.404,.404033,40,9,2)
 ;;=9,23^3^9,10
 ;;^DIST(.404,.404033,40,9,3)
 ;;=!M
 ;;^DIST(.404,.404033,40,9,3.1)
 ;;=S Y=$G(DDGFDL0)
 ;;^DIST(.404,.404033,40,9,4)
 ;;=1
 ;;^DIST(.404,.404033,40,9,20)
 ;;=DD^^.4044,4.2
 ;;^DIST(.404,.404033,40,9,23)
 ;;=S DDGFDL=X
 ;;^DIST(.404,.404033,40,10,0)
 ;;=4^RIGHT JUSTIFY^3
 ;;^DIST(.404,.404033,40,10,1)
 ;;=6.3
 ;;^DIST(.404,.404033,40,10,2)
 ;;=6,23^3^6,8
 ;;^DIST(.404,.404033,40,11,0)
 ;;=5^DISPLAY GROUP^3
 ;;^DIST(.404,.404033,40,11,1)
 ;;=3
 ;;^DIST(.404,.404033,40,11,2)
 ;;=7,23^20^7,8
 ;;^DIST(.404,.404034,0)
 ;;=DDGF FIELD DD OTHER WP^.4044
 ;;^DIST(.404,.404034,40,0)
 ;;=^.4044I^10^7
 ;;^DIST(.404,.404034,40,1,0)
 ;;=1^ Other Parameters ^1
 ;;^DIST(.404,.404034,40,1,2)
 ;;=^^1,14^1
 ;;^DIST(.404,.404034,40,2,0)
 ;;=2^REQUIRED^3
 ;;^DIST(.404,.404034,40,2,1)
 ;;=6.1
 ;;^DIST(.404,.404034,40,2,2)
 ;;=3,23^3^3,13
 ;;^DIST(.404,.404034,40,3,0)
 ;;=3^DISABLE EDITING^3
 ;;^DIST(.404,.404034,40,3,1)
 ;;=6.4
 ;;^DIST(.404,.404034,40,3,2)
 ;;=4,23^3^4,6
 ;;^DIST(.404,.404034,40,3,14)
 ;;=I X=2 D HLP^DDSUTL("Word processing fields are always reachable.  To make the field uneditable, enter 'YES'.") S DDSERROR=1
 ;;^DIST(.404,.404034,40,7,0)
 ;;=4^DISPLAY GROUP^3
 ;;^DIST(.404,.404034,40,7,1)
 ;;=3
 ;;^DIST(.404,.404034,40,7,2)
 ;;=5,23^20^5,8
 ;;^DIST(.404,.404034,40,8,0)
 ;;=5^DATA LENGTH^2
 ;;^DIST(.404,.404034,40,8,2)
 ;;=7,23^3^7,10
 ;;^DIST(.404,.404034,40,8,3)
 ;;=!M
 ;;^DIST(.404,.404034,40,8,3.1)
 ;;=S Y=$G(DDGFDL0)
 ;;^DIST(.404,.404034,40,8,4)
 ;;=1
 ;;^DIST(.404,.404034,40,8,20)
 ;;=DD^^.4044,4.2
 ;;^DIST(.404,.404034,40,8,23)
 ;;=S DDGFDL=X
 ;;^DIST(.404,.404034,40,9,0)
 ;;=6^CAPTION COORDINATE^2
 ;;^DIST(.404,.404034,40,9,2)
 ;;=8,23^7^8,3

DINIT0F7
DINIT0F7 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F8 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.404034,40,9,3)
 ;;=!M
 ;;^DIST(.404,.404034,40,9,3.1)
 ;;=S Y=$G(DDGFCC0)
 ;;^DIST(.404,.404034,40,9,20)
 ;;=DD^^.4044,5.1
 ;;^DIST(.404,.404034,40,9,23)
 ;;=S DDGFCC=X
 ;;^DIST(.404,.404034,40,10,0)
 ;;=7^DATA COORDINATE^2
 ;;^DIST(.404,.404034,40,10,2)
 ;;=9,23^7^9,6
 ;;^DIST(.404,.404034,40,10,3)
 ;;=!M
 ;;^DIST(.404,.404034,40,10,3.1)
 ;;=S Y=$G(DDGFDC0)
 ;;^DIST(.404,.404034,40,10,4)
 ;;=1
 ;;^DIST(.404,.404034,40,10,20)
 ;;=DD^^.4044,4.1
 ;;^DIST(.404,.404034,40,10,23)
 ;;=S DDGFDC=X
 ;;^DIST(.404,.404041,0)
 ;;=DDGF FIELD FORM ONLY^.4044
 ;;^DIST(.404,.404041,40,0)
 ;;=^.4044I^17^14
 ;;^DIST(.404,.404041,40,1,0)
 ;;=1^ Form Only Field Properties ^1
 ;;^DIST(.404,.404041,40,1,2)
 ;;=^^1,25
 ;;^DIST(.404,.404041,40,2,0)
 ;;=2^FIELD ORDER^3
 ;;^DIST(.404,.404041,40,2,1)
 ;;=.01
 ;;^DIST(.404,.404041,40,2,2)
 ;;=3,26^4^3,13
 ;;^DIST(.404,.404041,40,5,0)
 ;;=8^DEFAULT^3
 ;;^DIST(.404,.404041,40,5,1)
 ;;=6
 ;;^DIST(.404,.404041,40,5,2)
 ;;=8,26^50^8,17
 ;;^DIST(.404,.404041,40,5,13)
 ;;=D:X'="!M" PUT^DDSVAL(.4044,.DA,6.01,"")
 ;;^DIST(.404,.404041,40,7,0)
 ;;=11^BRANCHING LOGIC^3
 ;;^DIST(.404,.404041,40,7,1)
 ;;=10
 ;;^DIST(.404,.404041,40,7,2)
 ;;=12,26^50^12,9
 ;;^DIST(.404,.404041,40,8,0)
 ;;=12^PRE ACTION^3
 ;;^DIST(.404,.404041,40,8,1)
 ;;=11
 ;;^DIST(.404,.404041,40,8,2)
 ;;=13,26^50^13,14
 ;;^DIST(.404,.404041,40,9,0)
 ;;=13^POST ACTION^3
 ;;^DIST(.404,.404041,40,9,1)
 ;;=12
 ;;^DIST(.404,.404041,40,9,2)
 ;;=14,26^50^14,13
 ;;^DIST(.404,.404041,40,10,0)
 ;;=14^POST ACTION ON CHANGE^3
 ;;^DIST(.404,.404041,40,10,1)
 ;;=13
 ;;^DIST(.404,.404041,40,10,2)
 ;;=15,26^50^15,3
 ;;^DIST(.404,.404041,40,11,0)
 ;;=9^EXECUTABLE CAPTION^3
 ;;^DIST(.404,.404041,40,11,1)
 ;;=1.1
 ;;^DIST(.404,.404041,40,11,2)
 ;;=9,26^50^9,6
 ;;^DIST(.404,.404041,40,11,13)
 ;;=D PUT^DDSVALF("CAPTION","","",$S(X="":"",1:"!M"))
 ;;^DIST(.404,.404041,40,12,0)
 ;;=10^EXECUTABLE DEFAULT^3
 ;;^DIST(.404,.404041,40,12,1)
 ;;=6.01
 ;;^DIST(.404,.404041,40,12,2)
 ;;=10,26^50^10,6
 ;;^DIST(.404,.404041,40,12,13)
 ;;=D PUT^DDSVAL(.4044,.DA,6,$S(X="":"",1:"!M"))
 ;;^DIST(.404,.404041,40,13,0)
 ;;=3^FORM ONLY FIELD PARAMETERS...^2
 ;;^DIST(.404,.404041,40,13,2)
 ;;=3,73^1^3,43^1
 ;;^DIST(.404,.404041,40,13,7)
 ;;=^11
 ;;^DIST(.404,.404041,40,13,20)
 ;;=F^^0:0
 ;;^DIST(.404,.404041,40,13,21,0)
 ;;=^^1^1^2940928^
 ;;^DIST(.404,.404041,40,13,21,1,0)
 ;;=Press <RET> to edit the properties of this form-only field
 ;;^DIST(.404,.404041,40,14,0)
 ;;=4^OTHER PARAMETERS...^2
 ;;^DIST(.404,.404041,40,14,2)
 ;;=4,26^1^4,6^1
 ;;^DIST(.404,.404041,40,14,7)
 ;;=^21
 ;;^DIST(.404,.404041,40,14,20)
 ;;=F^^0:0
 ;;^DIST(.404,.404041,40,14,21,0)
 ;;=^^1^1^2940928^
 ;;^DIST(.404,.404041,40,14,21,1,0)
 ;;=Press <RET> to edit additional properties of this form-only field
 ;;^DIST(.404,.404041,40,15,0)
 ;;=7^CAPTION^2
 ;;^DIST(.404,.404041,40,15,2)
 ;;=7,26^50^7,17
 ;;^DIST(.404,.404041,40,15,3)
 ;;=!M
 ;;^DIST(.404,.404041,40,15,3.1)
 ;;=S Y=$G(DDGFCAP0)
 ;;^DIST(.404,.404041,40,15,13)
 ;;=D FOCAP^DDGFU
 ;;^DIST(.404,.404041,40,15,20)
 ;;=DD^^.4044,1
 ;;^DIST(.404,.404041,40,15,23)
 ;;=S DDGFCAP=X
 ;;^DIST(.404,.404041,40,16,0)
 ;;=5^SUPPRESS COLON AFTER CAPTION?^2
 ;;^DIST(.404,.404041,40,16,2)
 ;;=4,73^3^4,43^1
 ;;^DIST(.404,.404041,40,16,3)
 ;;=!M
 ;;^DIST(.404,.404041,40,16,3.1)
 ;;=S Y=$G(DDGFSUP0)
 ;;^DIST(.404,.404041,40,16,20)
 ;;=DD^^.4044,5.2
 ;;^DIST(.404,.404041,40,16,23)
 ;;=S DDGFSUP=X
 ;;^DIST(.404,.404041,40,17,0)
 ;;=6^UNIQUE NAME^3
 ;;^DIST(.404,.404041,40,17,1)
 ;;=3.1
 ;;^DIST(.404,.404041,40,17,2)
 ;;=5,26^50^5,13
 ;;^DIST(.404,.404042,0)
 ;;=DDGF FIELD FORM ONLY PARAMS^.4044
 ;;^DIST(.404,.404042,40,0)
 ;;=^.4044I^9^8
 ;;^DIST(.404,.404042,40,1,0)
 ;;=1^ Other Form Only Field Parameters ^1
 ;;^DIST(.404,.404042,40,1,2)
 ;;=^^1,22
 ;;^DIST(.404,.404042,40,2,0)
 ;;=2^READ TYPE^3
 ;;^DIST(.404,.404042,40,2,1)
 ;;=20.1
 ;;^DIST(.404,.404042,40,2,2)
 ;;=3,20^15^3,9
 ;;^DIST(.404,.404042,40,2,4)
 ;;=1
 ;;^DIST(.404,.404042,40,3,0)
 ;;=3^PARAMETERS^3
 ;;^DIST(.404,.404042,40,3,1)
 ;;=20.2
 ;;^DIST(.404,.404042,40,3,2)
 ;;=4,20^2^4,8
 ;;^DIST(.404,.404042,40,4,0)
 ;;=4^QUALIFIERS^3
 ;;^DIST(.404,.404042,40,4,1)
 ;;=20.3
 ;;^DIST(.404,.404042,40,4,2)
 ;;=5,20^52^5,8
 ;;^DIST(.404,.404042,40,5,0)
 ;;=6^INPUT TRANSFORM^3
 ;;^DIST(.404,.404042,40,5,1)
 ;;=22
 ;;^DIST(.404,.404042,40,5,2)
 ;;=9,20^52^9,3
 ;;^DIST(.404,.404042,40,6,0)
 ;;=5^HELP (WP)^3

DINIT0F8
DINIT0F8 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F9 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.404042,40,6,1)
 ;;=21
 ;;^DIST(.404,.404042,40,6,2)
 ;;=7,20^1^7,9
 ;;^DIST(.404,.404042,40,8,0)
 ;;=7^SCREEN^3
 ;;^DIST(.404,.404042,40,8,1)
 ;;=24
 ;;^DIST(.404,.404042,40,8,2)
 ;;=10,20^52^10,12
 ;;^DIST(.404,.404042,40,9,0)
 ;;=8^SAVE CODE^3
 ;;^DIST(.404,.404042,40,9,1)
 ;;=23
 ;;^DIST(.404,.404042,40,9,2)
 ;;=11,20^52^11,9
 ;;^DIST(.404,.404051,0)
 ;;=DDGF FIELD COMPUTED^.4044
 ;;^DIST(.404,.404051,40,0)
 ;;=^.4044I^8^8
 ;;^DIST(.404,.404051,40,1,0)
 ;;=1^ Computed Field Properties ^1
 ;;^DIST(.404,.404051,40,1,2)
 ;;=^^1,26
 ;;^DIST(.404,.404051,40,2,0)
 ;;=2^FIELD ORDER^3
 ;;^DIST(.404,.404051,40,2,1)
 ;;=.01
 ;;^DIST(.404,.404051,40,2,2)
 ;;=3,24^4^3,11
 ;;^DIST(.404,.404051,40,3,0)
 ;;=3^OTHER PARAMETERS...^2
 ;;^DIST(.404,.404051,40,3,2)
 ;;=4,24^1^4,4^1
 ;;^DIST(.404,.404051,40,3,7)
 ;;=^11
 ;;^DIST(.404,.404051,40,3,20)
 ;;=F^^1:1
 ;;^DIST(.404,.404051,40,3,21,0)
 ;;=^^1^1^2930916^
 ;;^DIST(.404,.404051,40,3,21,1,0)
 ;;=Press 'RETURN' to edit additional properties of this Data Dictionary field
 ;;^DIST(.404,.404051,40,4,0)
 ;;=4^SUPPRESS COLON AFTER CAPTION?^2
 ;;^DIST(.404,.404051,40,4,2)
 ;;=4,71^3^4,41^1
 ;;^DIST(.404,.404051,40,4,3)
 ;;=!M
 ;;^DIST(.404,.404051,40,4,3.1)
 ;;=S Y=DDGFSUP0
 ;;^DIST(.404,.404051,40,4,20)
 ;;=DD^^.4044,5.2
 ;;^DIST(.404,.404051,40,4,23)
 ;;=S DDGFSUP=X
 ;;^DIST(.404,.404051,40,5,0)
 ;;=5^UNIQUE NAME^3
 ;;^DIST(.404,.404051,40,5,1)
 ;;=3.1
 ;;^DIST(.404,.404051,40,5,2)
 ;;=5,24^50^5,11
 ;;^DIST(.404,.404051,40,6,0)
 ;;=6^CAPTION^2
 ;;^DIST(.404,.404051,40,6,2)
 ;;=7,24^50^7,15
 ;;^DIST(.404,.404051,40,6,3)
 ;;=!M
 ;;^DIST(.404,.404051,40,6,3.1)
 ;;=S Y=DDGFCAP0
 ;;^DIST(.404,.404051,40,6,13)
 ;;=D COMPCAP^DDGFU
 ;;^DIST(.404,.404051,40,6,20)
 ;;=DD^^.4044,1
 ;;^DIST(.404,.404051,40,6,23)
 ;;=S DDGFCAP=X
 ;;^DIST(.404,.404051,40,7,0)
 ;;=7^EXECUTABLE CAPTION^3
 ;;^DIST(.404,.404051,40,7,1)
 ;;=1.1
 ;;^DIST(.404,.404051,40,7,2)
 ;;=8,24^50^8,4
 ;;^DIST(.404,.404051,40,7,13)
 ;;=D PUT^DDSVALF("CAPTION","","",$S(X="":"",1:"!M"))
 ;;^DIST(.404,.404051,40,8,0)
 ;;=8^COMPUTED EXPRESSION^3
 ;;^DIST(.404,.404051,40,8,1)
 ;;=30
 ;;^DIST(.404,.404051,40,8,2)
 ;;=10,24^50^10,3
 ;;^DIST(.404,.404051,40,8,4)
 ;;=1
 ;;^DIST(.404,.404052,0)
 ;;=DDGF FIELD COMPUTED OTHER^.4044
 ;;^DIST(.404,.404052,40,0)
 ;;=^.4044I^8^5
 ;;^DIST(.404,.404052,40,1,0)
 ;;=1^ Other Computed Field Properties ^1
 ;;^DIST(.404,.404052,40,1,2)
 ;;=^^1,6
 ;;^DIST(.404,.404052,40,5,0)
 ;;=3^DATA LENGTH^2
 ;;^DIST(.404,.404052,40,5,2)
 ;;=5,25^3^5,12
 ;;^DIST(.404,.404052,40,5,3)
 ;;=!M
 ;;^DIST(.404,.404052,40,5,3.1)
 ;;=S Y=$G(DDGFDL0)
 ;;^DIST(.404,.404052,40,5,20)
 ;;=DD^^.4044,4.2
 ;;^DIST(.404,.404052,40,5,23)
 ;;=S DDGFDL=X
 ;;^DIST(.404,.404052,40,6,0)
 ;;=4^CAPTION COORDINATE^2
 ;;^DIST(.404,.404052,40,6,2)
 ;;=6,25^7^6,5
 ;;^DIST(.404,.404052,40,6,3)
 ;;=!M
 ;;^DIST(.404,.404052,40,6,3.1)
 ;;=S Y=$G(DDGFCC0)
 ;;^DIST(.404,.404052,40,6,20)
 ;;=DD^^.4044,5.1
 ;;^DIST(.404,.404052,40,6,23)
 ;;=S DDGFCC=X
 ;;^DIST(.404,.404052,40,7,0)
 ;;=5^DATA COORDINATE^2
 ;;^DIST(.404,.404052,40,7,2)
 ;;=7,25^7^7,8
 ;;^DIST(.404,.404052,40,7,3)
 ;;=!M
 ;;^DIST(.404,.404052,40,7,3.1)
 ;;=S Y=$G(DDGFDC0)
 ;;^DIST(.404,.404052,40,7,20)
 ;;=DD^^.4044,4.1
 ;;^DIST(.404,.404052,40,7,23)
 ;;=S DDGFDC=X
 ;;^DIST(.404,.404052,40,8,0)
 ;;=2^RIGHT JUSTIFY^3
 ;;^DIST(.404,.404052,40,8,1)
 ;;=6.3
 ;;^DIST(.404,.404052,40,8,2)
 ;;=3,25^3^3,10
 ;;^DIST(.404,.404061,0)
 ;;=DDGF BLOCK ADD
 ;;^DIST(.404,.404061,40,0)
 ;;=^.4044I^1^1
 ;;^DIST(.404,.404061,40,1,0)
 ;;=1^Select NEW BLOCK NAME^2
 ;;^DIST(.404,.404061,40,1,2)
 ;;=3,26^30^3,3
 ;;^DIST(.404,.404061,40,1,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.404061,40,1,20)
 ;;=P^^DIST(.404,:QEALMZF
 ;;^DIST(.404,.404061,40,1,23)
 ;;=S DDGFBNUM=X,DDGFBNAM=DDSEXT
 ;;^DIST(.404,.404061,40,1,24)
 ;;=S DIR("S")="I Y'<1"
 ;;^DIST(.404,.404062,0)
 ;;=DDGF BLOCK ADD NEW
 ;;^DIST(.404,.404062,40,0)
 ;;=^.4044I^2^2
 ;;^DIST(.404,.404062,40,1,0)
 ;;=1^!M^1
 ;;^DIST(.404,.404062,40,1,.1)
 ;;=S Y="Are you adding "_DDGFBNAM
 ;;^DIST(.404,.404062,40,1,2)
 ;;=^^3,3
 ;;^DIST(.404,.404062,40,2,0)
 ;;=2^as a new block on this page?^2
 ;;^DIST(.404,.404062,40,2,2)
 ;;=4,32^3^4,3^1
 ;;^DIST(.404,.404062,40,2,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.404062,40,2,20)
 ;;=Y
 ;;^DIST(.404,.404062,40,2,23)
 ;;=S DDGFANS=X
 ;;^DIST(.404,.404063,0)
 ;;=DDGF BLOCK ADD DUPLICATE
 ;;^DIST(.404,.404063,40,0)
 ;;=^.4044I^3^3

DINIT0F9
DINIT0F9 ;SFISC/MKO-FORMS AND BLOCKS FOR FORM EDITOR ;11/23/94  1:24 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT02 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.404,.404063,40,1,0)
 ;;=1^!M^1
 ;;^DIST(.404,.404063,40,1,.1)
 ;;=S Y="Block "_DDGFBNAM
 ;;^DIST(.404,.404063,40,1,2)
 ;;=^^3,3
 ;;^DIST(.404,.404063,40,2,0)
 ;;=2^already exists on this page!^1
 ;;^DIST(.404,.404063,40,2,2)
 ;;=^^4,3
 ;;^DIST(.404,.404063,40,3,0)
 ;;=3^OK^2
 ;;^DIST(.404,.404063,40,3,2)
 ;;=6,18^1^6,15^1
 ;;^DIST(.404,.404063,40,3,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.404063,40,3,20)
 ;;=F^^0:0
 ;;^DIST(.404,.404063,40,3,21,0)
 ;;=^^1^1^2940928^
 ;;^DIST(.404,.404063,40,3,21,1,0)
 ;;=Press <RET> to close this page
 ;;^DIST(.404,.404071,0)
 ;;=DDGF BLOCK DELETE
 ;;^DIST(.404,.404071,40,0)
 ;;=^.4044I^4^4
 ;;^DIST(.404,.404071,40,1,0)
 ;;=1^Block^1
 ;;^DIST(.404,.404071,40,1,2)
 ;;=^^1,1
 ;;^DIST(.404,.404071,40,2,0)
 ;;=4^Do you want to delete it from the BLOCK file?^2
 ;;^DIST(.404,.404071,40,2,2)
 ;;=3,47^3^3,1^1
 ;;^DIST(.404,.404071,40,2,12)
 ;;=S:X]"" DDACT="EX" I X="" D HLP^DDSUTL($C(7)_"A response is required.  Enter either YES or NO.") S DDSBR=2
 ;;^DIST(.404,.404071,40,2,20)
 ;;=Y
 ;;^DIST(.404,.404071,40,2,23)
 ;;=S DDGFANS=X
 ;;^DIST(.404,.404071,40,3,0)
 ;;=2^!M^1
 ;;^DIST(.404,.404071,40,3,.1)
 ;;=S Y=DDGFBK
 ;;^DIST(.404,.404071,40,3,2)
 ;;=^^1,7
 ;;^DIST(.404,.404071,40,4,0)
 ;;=3^is not used on any other forms.^1
 ;;^DIST(.404,.404071,40,4,2)
 ;;=^^2,1
 ;;^DIST(.404,.404081,0)
 ;;=DDGF HEADER BLOCK SELECT
 ;;^DIST(.404,.404081,40,0)
 ;;=^.4044I^2^2
 ;;^DIST(.404,.404081,40,1,0)
 ;;=1^ Add a New Header Block ^1
 ;;^DIST(.404,.404081,40,1,2)
 ;;=^^1,20
 ;;^DIST(.404,.404081,40,2,0)
 ;;=2^Select New Header Block Name^2
 ;;^DIST(.404,.404081,40,2,2)
 ;;=3,33^30^3,3
 ;;^DIST(.404,.404081,40,2,12)
 ;;=S DDACT="EX"
 ;;^DIST(.404,.404081,40,2,20)
 ;;=P^^DIST(.404,:QEALMZF
 ;;^DIST(.404,.404081,40,2,23)
 ;;=S DDGFBNUM=X,DDGFBNAM=DDSEXT

DINIT1
DINIT1 ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;7/27/94  10:21 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT11:X?.P S @("^DD(0,"_$E($P(X," ",2),3,99)_")=Y")
 ;;.26,0 COMPUTE ALGORITHM^FJ30^^9.1;E1,245^K:$L(X)>50 X
 ;;.27,0 SUB-FIELDS^CJ1^^ ; ^Q:$D(DIQ(0))  X ^DD(0,.27,9.2) S X="" I $D(Y)#2,Y=U S DN=0
 ;;.27,9.2 S %=$S($D(^DD(DFF,D0,0)):+$P(^(0),U,2),1:0) I %,$D(^DD(%,.01,0)),$P(^(0),U,2)'["W" S DR="DFF=%,DN=1 D ^DIO2 S X="""",DFF="_DFF_",DN="_DN,X="D0" X "F Z=1:1 S DR=X_""=0,""_DR_"",""_X_""=""""""_@X_"""""""",X=""D""_X Q:$D(@X)[0","S "_DR
 ;;.28,0 MULTIPLE-VALUED^CB^^ ; ^S X=$P(^DD(DFF,D0,0),U,2)>0
 ;;.29,0 DEPTH OF SUB-FIELD^CJ1^^ ; ^S %=DFF X "F X=0:1 Q:'$D(^DD(%,0,""UP""))  S %=^(""UP"")"
 ;;.3,0 POINTER^F^^0;3
 ;;.3,9 ^
 ;;.4,0 GLOBAL SUBSCRIPT LOCATION^RF^^0;4^K:X'?1.E1";"1.E X I $D(X),@("$D("_DIC_"""GL"",$P(X,"";""),$P(X,"";"",2)))") K X
 ;;.4,1,0 ^.1^1^1
 ;;.4,1,1,0 DA(2)^GL
 ;;.4,1,1,1 S:X'?.P @(DIC_"""GL"",$P(X,"";""),$P(X,"";"",2),DA)=""""")
 ;;.4,1,1,2 K:X'?.P @(DIC_"""GL"",$P(X,"";""),$P(X,"";"",2),DA)")
 ;;.4,9 ^
 ;;.5,0 INPUT TRANSFORM^CJ44^^ ; ^S @("X=$P("_DCC_"D0,0),U,5,99)")
 ;;.5,9 ^
 ;;1,0 CROSS-REFERENCE^.1^^1;0
 ;;1.1,0 AUDIT^S^y:YES, ALWAYS;n:NO;e:EDITED OR DELETED;^AUDIT;1^Q
 ;;1.1,1,0 ^.1
 ;;1.1,1,1,0 0^AUD^MUMPS
 ;;1.1,1,1,1 I "ye"[X,$P(^DD(DA(1),DA,0),U,2)'["a" S $P(^(0),U,2)=$P(^(0),U,2)_"a"
 ;;1.1,1,1,2 S $P(^(0),U,2)=$P($P(^DD(DA(1),DA,0),U,2),"a")_$P($P(^(0),U,2),"a",2,9)
 ;;1.1,1,2,0 0^AUDIT^MUMPS
 ;;1.1,1,2,1 S:"ye"[X ^DD(DA(1),"AUDIT",DA)=""
 ;;1.1,1,2,2 K ^DD(DA(1),"AUDIT",DA)
 ;;1.2,0 AUDIT CONDITION^K^^AX;E1,245^D ^DIM
 ;;1.2,3 Enter Mumps Code that will set $T to 1 for Audit to take place.
 ;;2,0 OUTPUT TRANSFORM^F^^2;E1,245;D ^DIM
 ;;3,0 'HELP'-PROMPT^F^^3;E1,245^K:X'?3.E!($L(X)>200) X
 ;;4,0 XECUTABLE 'HELP'^F^^4;E1,245^D ^DIM
 ;;8,0 READ ACCESS (OPTIONAL)^F^^8;E1,245^I DUZ(0)'="@" F I=1:1:$L(X) I DUZ(0)'[$E(X,I) K X Q
 ;;8,3 ENTER A STRING OF CHARACTERS WHICH ARE IN YOUR OWN ACCESS CODE ('DUZ(0)')
 ;;8.5,0 DELETE ACCESS (OPTIONAL)^F^^8.5;E1,245^I DUZ(0)'="@" F I=1:1:$L(X) I DUZ(0)'[$E(X,I) K X Q
 ;;9,0 WRITE ACCESS (OPTIONAL)^F^^9;E1,245^I DUZ(0)'="@" F I=1:1:$L(X) I DUZ(0)'[$E(X,I) K X Q
 ;;9.01,0 COMPUTED FIELDS USED^F^^9.01;E1,250^Q
 ;;9.01,1,0 ^.1^1^1
 ;;9.01,1,1,0 DA(2)^ACOMP^MUMPS
 ;;9.01,1,1,1 F %=1:1 S I=$P(X,";",%) Q:I=""  S ^DD("ACOMP",+I,+$P(I,U,2),DA(1),DA)=""
 ;;9.01,1,1,2 F %=1:1 S I=$P(X,";",%) Q:I=""  K ^DD("ACOMP",+I,+$P(I,U,2),DA(1),DA)
 ;;10,0 SOURCE^F^^10;E1,99^K:$L(X)>99 X
 ;;10,3 WHERE THIS DATA ELEMENT COMES FROM (UP TO 99 CHARACTERS)
 ;;11,0 DESTINATION^.2LAP^^11;0
 ;;12,0 POINTER SCREEN^^^12;E1,250
 ;;12.1,0 CODE TO SET POINTER SCREEN^^^12.1;E1,250^D ^DIM
 ;;12.2,0 EXPRESSION FOR POINTER SCREEN^^^12.2;E1,250
 ;;20,0 GROUP^.3LA^^20;0
 ;;21,0 DESCRIPTION^.001^^21;0

DINIT11
DINIT11 ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;7/22/94  08:07
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT11A:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;0,23,0 TECHNICAL DESCRIPTION^.001^^23;0
 ;;0,50,0 DATE FIELD LAST EDITED^D^^DT;1^Q
 ;;0,50,9 ^
 ;;0,999,0 TRIGGERED-BY POINTER^.15^^5;0
 ;;0,999,9 ^
 ;;.1,0,"NM","CROSS-REFERENCE"
 ;;.1,0 CROSS-REFERENCE^
 ;;.1,.01,0 INDEX^F^^0;E1,245^Q
 ;;.1,.01,1,0 ^.1^3^3
 ;;.1,.01,1,1,0 0^IX
 ;;.1,.01,1,1,1 S:$P(X,U,2)]"" @("^DD("_$P(X,"^",1)_",0,""IX"",$P(X,""^"",2),DA(2),DA(1))=""""")
 ;;.1,.01,1,1,2 K:$P(X,U,2)]"" @("^DD("_$P(X,"^",1)_",0,""IX"",$P(X,""^"",2),DA(2),DA(1))")
 ;;.1,.01,1,2,0 DA(2)^IX
 ;;.1,.01,1,2,1 S ^DD(DA(2),"IX",DA(1))=""
 ;;.1,.01,1,2,2 I $O(^DD(DA(2),DA(1),1,0))=DA,$O(^(DA))="" K ^DD(DA(2),"IX",DA(1))
 ;;.1,.01,1,3,0 ^^TRIGGER
 ;;.1,.01,1,3,1 S Y=$P(X,U,5),X=$P(X,U,4),Z=DA(2)_U_DA(1)_U_DA I Y F %=1:1 Q:'%  S %1=$S($D(^DD(X,Y,5,%,0)):^(0),1:0) Q:%1=Z  I '%1 S ^(0)=Z F %=-1:0 S ^DD(X,"TRB",DA(2),DA(1),DA,Y)="",Y=X Q:'$D(^DD(X,0,"UP"))  S X=^("UP"),Y=$O(^DD(X,"SB",Y,0))
 ;;.1,.01,1,3,2 S Y=$P(X,"^",5),X=$P(X,"^",4) I Y S %=0 F  S %=$O(^DD(X,Y,5,%)) Q:%=""  Q:'$D(^(%,0))  I DA(2)_"^"_DA(1)_"^"_DA=^(0) K ^DD(X,Y,5,%) F  K ^DD(X,"TRB",DA(2),DA(1),DA,Y) Q:'$D(^DD(X,0,"UP"))  S Y=X,X=^("UP"),Y=$O(^DD(X,"SB",Y,0))
 ;;.1,1,0 SET STATEMENT^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;.1,1,3 This is Standard MUMPS code.
 ;;.1,1,21,0 ^^3^3^2890802^
 ;;.1,1,21,1,0 Enter Standard MUMPS code which will set this cross-reference.
 ;;.1,1,21,2,0 You may use X to reference the data in this field and DA-array
 ;;.1,1,21,3,0 to reference the internal entry numbers in the file.
 ;;.1,1,"DEL",1,0 I 1 W $C(7),!,"CAN'T DELETE THIS NODE."
 ;;.1,2,0 KILL STATEMENT^K^^2;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;.1,2,3 This is Standard MUMPS code.
 ;;.1,2,21,0 ^^3^3^2890802^
 ;;.1,2,21,1,0 Enter Standard MUMPS code which will kill this cross-reference.
 ;;.1,2,21,2,0 You may use X to reference the data in this field and the DA-array
 ;;.1,2,21,3,0 to reference the internal entry numbers in the file.
 ;;.1,2,"DEL",1,0 I 1 W $C(7),!,"CAN'T DELETE THIS NODE."
 ;;.1,3,0 NO-DELETION MESSAGE^F^^3;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>245!($L(X)<3) X
 ;;.1,3,1,0 ^.1
 ;;.1,3,1,1,0 .1^AC^MUMPS
 ;;.1,3,1,1,1 Q
 ;;.1,3,1,1,2 K:^DD(DA(2),DA(1),1,DA,3)']"" ^(3)
 ;;.1,3,3 Answer must be 3-245 characters in length.
 ;;.1,3,21,0 ^^2^2^2890803^^
 ;;.1,3,21,1,0 Enter a message if you want to prevent this cross-reference from being
 ;;.1,3,21,2,0 deleted.
 ;;.1,4,0 DATE UPDATED^D^^DT;1^S %DT="ET" D ^%DT S X=Y K:Y<1 X
 ;;.1,10,0 DESCRIPTION^.101^^%D;0
 ;;.1,"IX",.01
 ;;.101,0 DESCRIPTION SUB-FIELD^^.01^1
 ;;.101,0,"UP" .1
 ;;.101,.01,0 DESCRIPTION^W^^0;1^Q

DINIT11A
DINIT11A ;SFISC/DCM-INITIALIZE VA FILEMAN ;7/22/94  08:14
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) Q:X?.P  S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;.001,0 DESCRIPTION^
 ;;.001,.01,0 DESCRIPTION^W^^0;1
 ;;.12,0 FIELD^
 ;;.12,0,"NM","VARIABLE-POINTER"
 ;;.12,.01,0 VARIABLE-POINTER^R*P1'^DIC(^0;1^S:DUZ(0)'="@" DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
 ;;.12,.01,1,0 ^.1
 ;;.12,.01,1,1,0 .12^B
 ;;.12,.01,1,1,1 S ^DD(DA(2),DA(1),"V","B",X,DA)=""
 ;;.12,.01,1,1,2 K ^DD(DA(2),DA(1),"V","B",X,DA)
 ;;.12,.01,1,2,0 .12^PT^MUMPS
 ;;.12,.01,1,2,1 S ^DD(+X,0,"PT",DA(2),DA(1))=""
 ;;.12,.01,1,2,2 K ^DD(+X,0,"PT",DA(2),DA(1))
 ;;.12,.01,4
 ;;.12,.01,12.1 S:DUZ(0)'="@" DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
 ;;.12,.02,0 MESSAGE^RF^^0;2^K:$L(X)>30!($L(X)<1) X
 ;;.12,.02,1,1,0 .12^M^MUMPS
 ;;.12,.02,1,1,1 S ^DD(DA(2),DA(1),"V","M",X,DA)=""
 ;;.12,.02,1,1,2 K ^DD(DA(2),DA(1),"V","M",X,DA)
 ;;.12,.02,3 ANSWER MUST BE 1-30 CHARACTERS IN LENGTH
 ;;.12,.03,0 ORDER^RNJ4,1X^^0;3^K:+X'=X!(X>99)!(X<1)!(X?.E1"."2N.N) X I $D(X),$D(^DD(DA(2),DA(1),"V","O",X)),$O(^(X,0))'=DA K X I $D(^DD(DA(2),DA(1),"V",$O(^(0)),0)) S %=+^(0) W:% "  Used by "_$S($D(^DIC(%,0)):$P(^(0),U,1),1:%)_" FILE "
 ;;.12,.03,1,0 ^.1
 ;;.12,.03,1,1,0 .12^O^MUMPS
 ;;.12,.03,1,1,1 S ^DD(DA(2),DA(1),"V","O",X,DA)=""
 ;;.12,.03,1,1,2 K ^DD(DA(2),DA(1),"V","O",X,DA)
 ;;.12,.03,3 Type a unique number between 1 and 99, one decimal point allowed.
 ;;.12,.04,0 PREFIX^RFX^^0;4^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>10 X I $D(X),$D(^DD(DA(2),DA(1),"V","P",X)),$O(^(X,0))'=DA K X I $D(^DD(DA(2),DA(1),"V",$O(^(0)),0)) S %=+^(0) W:% "  Used by "_$S($D(^DIC(%,0)):$P(^(0),U,1),1:%)_" FILE "
 ;;.12,.04,1,0 ^.1
 ;;.12,.04,1,1,0 .12^P^MUMPS
 ;;.12,.04,1,1,1 S ^DD(DA(2),DA(1),"V","P",X,DA)=""
 ;;.12,.04,1,1,2 K ^DD(DA(2),DA(1),"V","P",X,DA)
 ;;.12,.04,3 Answer must be a unique prefix, 1-10 characters in length
 ;;.12,.05,0 SHOULD ENTRIES BE SCREENED^S^y:YES;n:NO;^0;5^Q
 ;;.12,.06,0 LAYGO^S^y:YES;n:NO;^0;6^Q
 ;;.12,.06,.1 SHOULD USER BE ALLOWED TO ADD A NEW ENTRY
 ;;.12,1,0 SCREEN^FX^^1;E1,240^K:$L(X)>240!($L(X)<1)!(X'["DIC(""S"")") X D:$D(X) ^DIM
 ;;.12,1,.1 MUMPS CODE THAT WILL SET DIC('S')
 ;;.12,1,3 ANSWER MUST BE 1-240 CHARATERS IN LENGTH AND VALID MUMPS CODE
 ;;.12,1,4 I X?1"??".E D HELP^DICATT4
 ;;.12,1,"DEL",1,0 I $P(^DD(DA(2),DA(1),"V",DA,0),U,5)="y" W !?3,"Answer 'NO' to the 'SHOULD ENTRIES BE SCREENED' prompt to delete the screen"
 ;;.12,2,0 EXPLANATION OF SCREEN^FR^^2;1^K:$L(X)>240!($L(X)<1) X
 ;;.12,2,3 ANSWER MUST BE 1-240 CHARACTERS IN LENGTH
 ;;.15,0 TRIGGERED-BY^
 ;;.15,0,"NM","TRIGGERED-BY"
 ;;.15,.01,0 DD NUMBER^N^^0;1^K:'$D(^DD(X)) X
 ;;.15,2,0 FIELD NUMBER^N^^0;2
 ;;.15,3,0 CROSS-REFERENCE NUMBER^N^^0;3
 ;;.3,0 GROUP^
 ;;.3,0,"NM","GROUP"
 ;;.3,.01,0 GROUP^F^^0;1^K:$L(X)>30!(X'?.ANP)!($A(X)<32) X
 ;;.3,.01,3 UP TO 30 CHARACTERS, ALPHANUMERIC
 ;;.3,.01,1,0 ^.1^1^1
 ;;.3,.01,1,1,0 0^GR
 ;;.3,.01,1,1,1 S ^DD(DA(2),"GR",X,DA(1),DA)=""
 ;;.3,.01,1,1,2 K ^DD(DA(2),"GR",X,DA(1),DA)
 ;;"$O" S Y="%" F %=0:0 S Y=$O(@Y) Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 ;;"DD" S Y=$$FMTE^DILIBF(Y,"5U")
 ;;"KWIC" ^AND^THE^THEN^FOR^FROM^OTHER^THAN^WITH^THEIR^SOME^THIS^and^the^then^for^from^other^than^with^their^some^this

DINIT11B
DINIT11B ;SFISC/GFT,DCM-INITIALIZE VA FILEMAN ;7/22/94  08:14
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT11C:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;1,0 ATTRIBUTE^N
 ;;1,0,"NM","FILE"
 ;;1,.01,0 NAME^RF^^0;1^K:$L(X)>45!($L(X)<3) X
 ;;1,.01,1,0 ^.1^1^1
 ;;1,.01,1,1,0 1^B
 ;;1,.01,1,1,1 S @(DIC_"""B"",$E(X,1,30),DA)=""""")
 ;;1,.01,1,1,2 K @(DIC_"""B"",$E(X,1,30),DA)")
 ;;1,.01,1,2,0 1^AD^MUMPS
 ;;1,.01,1,2,1 I DIC'?1"^DOPT(".E,$D(^DIC(DA,0,"GL"))  S $P(@(^DIC(DA,0,"GL")_"0)"),U,1)=X
 ;;1,.01,1,2,2 Q
 ;;1,.01,1,3,0 1^AE^MUMPS
 ;;1,.01,1,3,1 S:DIC'?1"^DOPT(".E ^DD(DA,0,"NM",X)=""
 ;;1,.01,1,3,2 K ^DD(DA,0,"NM")
 ;;1,.01,3 3-45 CHARACTERS
 ;;1,.01,"DEL",1,0 I DIC="^DIC(" D K^DIU2
 ;;1,.01,"DEL",.5,0 I DIC="^DIC(" D POINT^DIDH I $O(^DD(DA,0,"PT",0))'=""
 ;;1,.01,"DEL","TRB",0 I $D(^DD(DA,"TRB")) D TRIG^DIDH
 ;;1,1,0 GLOBAL NAME^CJ14^^ ; ^S X=$S($D(^DIC(D0,0,"GL")):^("GL"),1:"")
 ;;1,1.1,0 ENTRIES^CJ7,0^^ ; ^S @("X=+$P("_$S($D(^DIC(D0,0,"GL")):"$S($D("_^("GL")_"0)):^(0),1:0)",1:0)_",""^"",4)")
 ;;1,4,0 DESCRIPTION^1.001^^%D;0
 ;;1.001,0 DESCRIPTION
 ;;1.001,.01,0 DESCRIPTION^W^^0;1
 ;;1.001,0,"UP" 1
 ;;1,10,0 APPLICATION GROUP^1.005^^%;0
 ;;1,20,0 DEVELOPER^P200^VA(200,^%A;1^Q
 ;;1,21,0 DATE^D^^%A;2^S %DT="" D ^%DT S X=Y K:X<9 X
 ;;1.005,0 APPLICATION GROUP^
 ;;1.005,0,"NM","APPLICATION-GROUP"
 ;;1.005,0,"UP" 1
 ;;1.005,.01,0 APPLICATION GROUP^MF^^0;1^K:X'?.U!($L(X)+1\3-1) X
 ;;1.005,.01,3 A 'NAMESPACE' (2-4 BYTES) INDICATING A PACKAGE ACCESSING THIS FILE
 ;;1.005,.01,1,0 ^.1^2^2
 ;;1.005,.01,1,1,0 1.005^B
 ;;1.005,.01,1,1,1 S ^DIC(DA(1),"%","B",X,DA)=""
 ;;1.005,.01,1,1,2 K ^DIC(DA(1),"%","B",X,DA)
 ;;1.005,.01,1,2,0 1^AC
 ;;1.005,.01,1,2,1 S ^DIC("AC",X,DA(1),DA)=""
 ;;1.005,.01,1,2,2 K ^DIC("AC",X,DA(1),DA)
 ;;1.005,1,0 PACKAGE NAME^CJ30^^ ; ^S X=$S($D(^DIC(9.4,+$O(^DIC(9.4,"C",X,0)),0)):$P(^(0),U,1),1:"")
 ;;1.01,0 ATTRIBUTE
 ;;1.01,0,"NM","OPTION"
 ;;1.01,.001,0 NUMBER^N^^ ^K:X\1'=X X
 ;;1.01,.01,0 NAME^RF^^0;1^K:$L(X)>70 X
 ;;1.01,.01,1,0 ^.1
 ;;1.01,.01,1,1,0 1.01^B
 ;;1.01,.01,1,1,1 S @(DIC_"""B"",$E(X,1,30),DA)=""""")
 ;;1.01,.01,1,1,2 K @(DIC_"""B"",$E(X,1,30),DA)")

DINIT11C
DINIT11C ;SFISC/GFT,DCM-INITIALIZE VA FILEMAN ;9/9/94  14:01
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 F I=1:1:6 S D=$P("DD^RD^WR^DEL^LAYGO^AUDIT",U,I),^DD(1,30+I,0)=D_" ACCESS^C^^ ; ^S X=$S($D(^DIC(D0,0,"""_D_""")):^("""_D_"""),1:"""")"
 S ^DD(1,50,0)="LOOKUP PROGRAM^C^^ ; ^S X=$S($D(^DD(D0,0,""DIC"")):^(""DIC""),1:"""")"
 S ^DD(1,51,0)="VERSION^CJ8^^ ; ^S X=$P($G(^DD(D0,0,""VR"")),U)"
 S ^DD(1,51.1,0)="DISTRIBUTION PACKAGE^CJ30^^ ; ^S X=$G(^DD(D0,0,""VRPK""))"
 S ^DD(1,51.2,0)="PACKAGE REVISION DATA^CJ240^^ ; ^S X=$G(^DD(D0,0,""VRRV""))"
 ;S ^DD(1,53,0)="RESTRICT EDITING OF FILE^C^^ ; ^S X=$S($D(^DD(D0,0,""DI"")):$P(^(""DI""),U,2),1:"""")"
 S ^DD(1,54,0)="ARCHIVE FILE^C^^ ; ^S X=$S($D(^DD(D0,0,""DI"")):$P(^(""DI""),U),1:"""")"
 S ^DD(1,1815,0)="COMPILED X-REF ROUTINE^CJ9^^ ; ^S X=$G(^DD(D0,0,""DIK""))"
 S ^DD(1,1816,0)="OLD COMPILED X-REF ROUTINE^CJ8^^ ; ^S X=$G(^DD(D0,0,""DIKOLD""))"
 S ^DD(1,1819,0)="COMPILED CROSS-REFERENCES^CJ3^^ ; ^S X=$S($G(^DD(D0,0,""DIK""))]"""":""YES"",1:""NO"")"
 S ^DD(1,1819,21,0)="^^3^3^2930709^",^(1,0)="Computed field that indicates whether or not cross-references are",^DD(1,1819,21,2,0)="compiled.  This field can be seen when doing an INQUIRE to the FILE "
 S ^DD(1,1819,21,3,0)="file (file #1, sometimes referred to as the file of files.)"
 F I=1815,1816,1819 S ^DD(1,I,9)="^",^(9.01)="",^(9.1)=$P(^(0),U,5,99)
 S $P(^DIC(0),U,1,2)="FILE^1",^DIC(1,0)="FILE^1",^(0,"GL")="^DIC(" D A
 S ^DIC(1,"%D",0)="^^2^2^2940908^"
 S ^DIC(1,"%D",1,0)="This file stores the descriptive information for all files in the FileMan"
 S ^DIC(1,"%D",2,0)="managed database."
 S ^DD(1,.001,0)="NUMBER^N^^ ^K:X<2!$D(^DD(X)) X I $D(X),$D(^VA(200,DUZ,1))#2,$P(^(1),U)]"""" I X<$P(^(1),""-"")!(X>$P($P(^(1),U),""-"",2)) K X"
 S ^(4)="W !?5,""Enter an unused number"" I $D(^VA(200,DUZ,1)),$P(^(1),U)]"""" W "" within the range, "",$P(^(1),U)"
 ;
 F I=.1,0 D XX,XX
 F I=.001,.1,.12,.15,.101,.3,1,1.005,1.01 D XX
 Q
 ;
XX S DA(1)=I,DIK="^DD("_I_","
X W ".." D IXALL^DIK
 Q
 ;
A S (^("RD"),^("LAYGO"),^("WR"),^("DD"))=U Q
A1 S (^("DEL"),^("LAYGO"),^("WR"),^("DD"))=U Q
 ;

DINIT12
DINIT12 ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;08:20 AM  14 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G T:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;.4,0 FIELD^^1819^21
 ;;.4,0,"DT" 2921229
 ;;.4,.01,0 NAME^F^^0;1^K:$L(X)<2!($L(X)>30) X
 ;;.4,.01,1,0 ^.1^2^2
 ;;.4,.01,1,1,0 .4^B
 ;;.4,.01,1,1,1 S @(DIC_"""B"",X,DA)=""""")
 ;;.4,.01,1,1,2 K @(DIC_"""B"",X,DA)")
 ;;.4,.01,1,2,0 ^^MUMPS
 ;;.4,.01,1,2,1 X "S %=$P("_DIC_"DA,0),U,4) S:$L(%) "_DIC_"""F""_+%,X,DA)=1"
 ;;.4,.01,1,2,2 X "S %=$P("_DIC_"DA,0),U,4) K:$L(%) "_DIC_"""F""_+%,X,DA)"
 ;;.4,.01,1,3,0 ^^MUMPS
 ;;.4,.01,1,3,1 Q
 ;;.4,.01,1,3,2 S X=-1 X "F  S X=$O("_DIC_"""AF"",X)) Q:X=""""  K:'X ^(X,DA) S Y=0 F  S Y=$O("_DIC_"""AF"",X,Y)) Q:Y'>0  K:$D(^(Y,DA)) ^(DA)" S X=-1 S:$G(Y)="" Y=-1
 ;;.4,.01,3 2-30 CHARACTERS
 ;;.4,2,0 DATE CREATED^D^^0;2^S %DT="ET" D ^%DT S X=Y K:Y<1 X
 ;;.4,3,0 READ ACCESS^F^^0;3^I DUZ(0)'="@" F I=1:1:$L(X) I DUZ(0)'[$E(X,I) K X Q
 ;;.4,4,0 FILE^P1'I^DIC(^0;4^Q
 ;;.4,4,1,0 ^.1^1^1
 ;;.4,4,1,1,0 ^^^MUMPS
 ;;.4,4,1,1,1 X "S %=$P("_DIC_"DA,0),U,1),"_DIC_"""F""_+X,%,DA)=1"
 ;;.4,4,1,1,2 Q
 ;;.4,5,0 USER #^N^^0;5^Q
 ;;.4,6,0 WRITE ACCESS^F^^0;6^I DUZ(0)'="@" F I=1:1:$L(X) I DUZ(0)'[$E(X,I) K X Q
 ;;.4,7,0 DATE LAST USED^D^^0;7^S %DT="EX" D ^%DT S X=Y K:Y<1 X
 ;;.4,1815,0 ROUTINE INVOKED^F^^ROU;E1,13^Q
 ;;.4,1815,9 @
 ;;.4,1816,0 PREVIOUS ROUTINE INVOKED^F^^ROUOLD;E1,13^Q
 ;;.4,1816,9 @
 ;;.4,10,0 DESCRIPTION^.4001^^%D;0
 ;;.4001,0 DESCRIPTION SUB-FIELD^^.01^1
 ;;.4001,0,"NM","DESCRIPTION"
 ;;.4001,0,"UP" .4
 ;;.4001,.01,0 DESCRIPTION^W^^0;1^Q
 ;
T ;
 ;;N D,D1,D2 S D2=^(0) S:$X>30 D1(1,"F")="!" S D=$P(D2,U,2) S:D D1(2)="("_$$FMTE^DILIBF(D)_")",D1(2,"F")="?30" S D=$P(D2,U,5) S:D D1(3)=" User #"_D,D1(3,"F")="?50" S D=$P(D2,U,4) S:D D1(4)=" File #"_D,D1(4,"F")="?59" D EN^DDIOL(.D1)
 S ^DD(.4,0,"ID","WRITE")=$P($T(T+1),";",3,99)
 S %X="^DD(.4," F %Y="^DD(.401,","^DD(.402," D %XY^%RCR
 S %X="^DD(.4001," F %Y="^DD(.4012,","^DD(.4021," D %XY^%RCR
 K ^DD(.402,1804),^("SB",.404),^DD(.402,"GL","RD",0,1804),^DD(.401,1815),^(1816),^(1620),^(.01,1,3)
 S ^DIC(.4,"%D",0)="^^3^3^2940908^"
 S ^DIC(.4,"%D",1,0)="This file stores the PRINT FIELDS data and other information about print"
 S ^DIC(.4,"%D",2,0)="templates.  These templates are used in the Print, Filegram, Extract, and"
 S ^DIC(.4,"%D",3,0)="Export options."
 S ^DIC(.402,"%D",0)="^^1^1^2940908^^"
 S ^DIC(.402,"%D",1,0)="This file stores the EDIT FIELDS data from an input template."
DD1 F I=1:1 S X=$T(DD1+I),Y=$P(X," ",3,99) G DD2:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;.4,0,"ID","WRIT" I $P(^(0),U,8) N D1 S @("D1=$P($P($C(59)_$S($D(^DD(.4,8,0)):$P(^(0),U,3),1:0)_$E("_DIC_"Y,0),0),$C(59)_$P(^(0),U,8)_"":"",2),$C(59),1)") D EN^DDIOL("**"_D1_"**","","?0")
 ;;.4,0,"ID","WRITED" I $G(DZ)?1"???".E N % S %=0 F  S %=$O(^DIPT(Y,"%D",%)) Q:%'>0  I $D(^(%,0))#2 D EN^DDIOL(^(0),"","!?5")
 ;;.401,0,"ID","WRITED" I $G(DZ)?1"???".E N % S %=0 F  S %=$O(^DIBT(Y,"%D",%)) Q:%'>0  I $D(^(%,0))#2 D EN^DDIOL(^(0),"","!?5")
 ;;.402,0,"ID","WRITED" I $G(DZ)?1"???".E N % S %=0 F  S %=$O(^DIE(Y,"%D",%)) Q:%'>0  I $D(^(%,0))#2 D EN^DDIOL(^(0),"","!?5")
 ;;.4,1819,0 COMPILED^CJ3^^ ; ^S X=$S('$D(^DIPT(D0,"ROU"))#2:"NO",^("ROU")="":"NO",1:"YES")
 ;;.4,1819,9 ^
 ;;.4,1819,9.01
 ;;.4,1819,9.1 S X=$S('$D(^DIPT(D0,"ROU"))#2:"NO",^("ROU")="":"NO",1:"YES")
 ;;.402,1819,0 COMPILED^CJ3^^ ; ^S X=$S('$D(^DIE(D0,"ROU"))#2:"NO",^("ROU")="":"NO",1:"YES")
 ;;.402,1819,9 ^
 ;;.402,1819,9.01
 ;;.402,1819,9.1 S X=$S('$D(^DIE(D0,"ROU"))#2:"NO",^("ROU")="":"NO",1:"YES")
 ;;
DD2 N DICNT F DICNT=0:1:7 D @("^DINIT12"_DICNT)
 K DICNT G ^DINIT13

DINIT120
DINIT120 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;11/4/94  09:44
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC(.401,0,"GL")
 ;;=^DIBT(
 ;;^DIC("B","SORT TEMPLATE",.401)
 ;;=
 ;;^DIC(.401,"%D",0)
 ;;=^^4^4^2940908^^
 ;;^DIC(.401,"%D",1,0)
 ;;=This file stores either SORT or SEARCH criteria. For SORT criteria, the
 ;;^DIC(.401,"%D",2,0)
 ;;=SORT DATA multiple contains the sort parameters. For SEARCH criteria, the
 ;;^DIC(.401,"%D",3,0)
 ;;=template also contains a list of record numbers selected as the result of
 ;;^DIC(.401,"%D",4,0)
 ;;=running the search.
 ;;^DD(.401,0)
 ;;=FIELD^^1819^18
 ;;^DD(.401,0,"DDA")
 ;;=N
 ;;^DD(.401,0,"DI")
 ;;=^
 ;;^DD(.401,0,"DT")
 ;;=2931221
 ;;^DD(.401,0,"ID","WRITED")
 ;;=I $G(DZ)?1"???".E N % S %=0 F  S %=$O(^DIBT(Y,"%D",%)) Q:%'>0  I $D(^(%,0))#2 D EN^DDIOL(^(0),"","!?5")
 ;;^DD(.401,0,"IX","B",.401,.01)
 ;;=
 ;;^DD(.401,0,"NM","SORT TEMPLATE")
 ;;=
 ;;^DD(.401,0,"PT",1.11,2)
 ;;=
 ;;^DD(.401,.01,0)
 ;;=NAME^F^^0;1^K:$L(X)<2!($L(X)>30) X
 ;;^DD(.401,.01,1,0)
 ;;=^.1^2^2
 ;;^DD(.401,.01,1,1,0)
 ;;=.401^B
 ;;^DD(.401,.01,1,1,1)
 ;;=S @(DIC_"""B"",X,DA)=""""")
 ;;^DD(.401,.01,1,1,2)
 ;;=K @(DIC_"""B"",X,DA)")
 ;;^DD(.401,.01,1,2,0)
 ;;=^^MUMPS
 ;;^DD(.401,.01,1,2,1)
 ;;=X "S %=$P("_DIC_"DA,0),U,4) S:$L(%) "_DIC_"""F""_+%,X,DA)=1"
 ;;^DD(.401,.01,1,2,2)
 ;;=X "S %=$P("_DIC_"DA,0),U,4) K:$L(%) "_DIC_"""F""_+%,X,DA)"
 ;;^DD(.401,.01,3)
 ;;=2-30 CHARACTERS
 ;;^DD(.401,9,0)
 ;;=SEARCH COMPLETE DATE^D^^QR;1^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(.401,9,3)
 ;;=Enter the date/time that this search was run to completion.
 ;;^DD(.401,9,21,0)
 ;;=^^4^4^2921124^
 ;;^DD(.401,9,21,1,0)
 ;;=  This field will be filled in automatically by the search option, but
 ;;^DD(.401,9,21,2,0)
 ;;=only if the search runs to completion.  It will contain the date/time
 ;;^DD(.401,9,21,3,0)
 ;;=that the search last ran.  If it was not allowed to run to completion,
 ;;^DD(.401,9,21,4,0)
 ;;=this field will be empty.
 ;;^DD(.401,9,23,0)
 ;;=^^1^1^2921124^^
 ;;^DD(.401,9,23,1,0)
 ;;=Filled in automatically by the FileMan search option.
 ;;^DD(.401,9,"DT")
 ;;=2921124
 ;;^DD(.401,11,0)
 ;;=TOTAL RECORDS SELECTED^NJ10,0^^QR;2^K:+X'=X!(X>9999999999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.401,11,3)
 ;;=Type a Number between 1 and 9999999999, 0 Decimal Digits
 ;;^DD(.401,11,21,0)
 ;;=^^5^5^2921125^^
 ;;^DD(.401,11,21,1,0)
 ;;=  This field is filled in automatically by the FileMan search option.
 ;;^DD(.401,11,21,2,0)
 ;;=If the search is allowed to run to completion, the total number of
 ;;^DD(.401,11,21,3,0)
 ;;=records that met the search criteria is stored in this field.  If the
 ;;^DD(.401,11,21,4,0)
 ;;=last search was not allowed to run to completion, this field will be
 ;;^DD(.401,11,21,5,0)
 ;;=null.
 ;;^DD(.401,11,23,0)
 ;;=^^1^1^2921124^
 ;;^DD(.401,11,23,1,0)
 ;;=Filled in automatically by the FileMan search option.
 ;;^DD(.401,11,"DT")
 ;;=2921125
 ;;^DD(.401,1621,0)
 ;;=SORT FIELD DATA^.4014^^2;0
 ;;^DD(.401,1815,0)
 ;;=ROUTINE INVOKED^F^^ROU;E1,13^K:$L(X)>5!($L(X)<5) X
 ;;^DD(.401,1815,3)
 ;;=Answer must be 5 characters in length.Must contain '^DISZ'.
 ;;^DD(.401,1815,21,0)
 ;;=^^7^7^2930331^^^
 ;;^DD(.401,1815,21,1,0)
 ;;=  If this sort template is compiled, the first characters of the name
 ;;^DD(.401,1815,21,2,0)
 ;;=of that compiled routine will appear on this node.  Compiled sort
 ;;^DD(.401,1815,21,3,0)
 ;;=routines are re-created each time the sort/print runs.  These characters
 ;;^DD(.401,1815,21,4,0)
 ;;=are concatenated with the next available number from the COMPILED ROUTINE
 ;;^DD(.401,1815,21,5,0)
 ;;=file to create the routine name.
 ;;^DD(.401,1815,21,6,0)
 ;;=  If this node is present, a new compiled sort routine will be created
 ;;^DD(.401,1815,21,7,0)
 ;;=during the FileMan sort/print.
 ;;^DD(.401,1815,23,0)
 ;;=^^3^3^2930331^^^
 ;;^DD(.401,1815,23,1,0)
 ;;=A routine beginning with these characters is created during the FileMan
 ;;^DD(.401,1815,23,2,0)
 ;;=sort/print.  The routine is then called from DIO2 to do the sort, rather
 ;;^DD(.401,1815,23,3,0)
 ;;=than executing code from the local DY, DZ and P arrays.
 ;;^DD(.401,1815,"DT")
 ;;=2930416
 ;;^DD(.401,1816,0)
 ;;=PREVIOUS ROUTINE INVOKED^F^^ROUOLD;E1,13^K:$L(X)>4!($L(X)<4)!'(X?1"DISZ") X

DINIT121
DINIT121 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.401,1816,3)
 ;;=Entry must be 'DISZ'.
 ;;^DD(.401,1816,21,0)
 ;;=^^4^4^2930331^^
 ;;^DD(.401,1816,21,1,0)
 ;;=This node is present only to be consistant with other sort templates.
 ;;^DD(.401,1816,21,2,0)
 ;;=It's presence will indicate that at some time the SORT template was
 ;;^DD(.401,1816,21,3,0)
 ;;=compiled and will contain the beginning characters used to create the
 ;;^DD(.401,1816,21,4,0)
 ;;=name of the compiled routine.
 ;;^DD(.401,1816,"DT")
 ;;=2930416
 ;;^DD(.401,1819,0)
 ;;=COMPILED^CJ3^^ ; ^S X=$S($G(^DIBT(D0,"ROU"))]"":"YES",1:"NO")
 ;;^DD(.401,1819,9)
 ;;=^
 ;;^DD(.401,1819,9.01)
 ;;=
 ;;^DD(.401,1819,9.1)
 ;;=S X=$S($G(^DIBT(D0,"ROU"))]"":"YES",1:"NO")
 ;;^DD(.4014,0)
 ;;=SORT FIELD DATA SUB-FIELD^^9.5^27
 ;;^DD(.4014,0,"DT")
 ;;=2931221
 ;;^DD(.4014,0,"IX","B",.4014,.01)
 ;;=
 ;;^DD(.4014,0,"NM","SORT FIELD DATA")
 ;;=
 ;;^DD(.4014,0,"UP")
 ;;=.401
 ;;^DD(.4014,.01,0)
 ;;=FILE OR SUBFILE NO.^MRNJ13,5^^0;1^K:+X'=X!(X>9999999.99999)!(X<0)!(X?.E1"."6N.N) X
 ;;^DD(.4014,.01,1,0)
 ;;=^.1
 ;;^DD(.4014,.01,1,1,0)
 ;;=.4014^B
 ;;^DD(.4014,.01,1,1,1)
 ;;=S ^DIBT(DA(1),2,"B",$E(X,1,30),DA)=""
 ;;^DD(.4014,.01,1,1,2)
 ;;=K ^DIBT(DA(1),2,"B",$E(X,1,30),DA)
 ;;^DD(.4014,.01,3)
 ;;=Type a Number between 0 and 9999999.99999, 5 Decimal Digits.  File or subfile number on which sort field resides.
 ;;^DD(.4014,.01,21,0)
 ;;=^^3^3^2930125^^
 ;;^DD(.4014,.01,21,1,0)
 ;;=This is the number of the file or subfile on which the sort field
 ;;^DD(.4014,.01,21,2,0)
 ;;=resides.  It is created automatically during the SORT FIELDS dialogue
 ;;^DD(.4014,.01,21,3,0)
 ;;=with the user in the sort/print option.
 ;;^DD(.4014,.01,23,0)
 ;;=^^1^1^2930125^^
 ;;^DD(.4014,.01,23,1,0)
 ;;=This number is automatically assigned by the print routine DIP.
 ;;^DD(.4014,.01,"DT")
 ;;=2930125
 ;;^DD(.4014,2,0)
 ;;=FIELD NO.^NJ13,5^^0;2^K:+X'=X!(X>9999999.99999)!(X<0)!(X?.E1"."6N.N) X
 ;;^DD(.4014,2,3)
 ;;=Type a Number between 0 and 9999999.99999, 5 Decimal Digits.  Sort field number, except for pointers, variable pointers and computed fields.
 ;;^DD(.4014,2,21,0)
 ;;=^^4^4^2930125^
 ;;^DD(.4014,2,21,1,0)
 ;;=On most sort fields, this piece will contain the field number.  If sorting
 ;;^DD(.4014,2,21,2,0)
 ;;=on a pointer, variable pointer or computed field, the piece will be null.
 ;;^DD(.4014,2,21,3,0)
 ;;=If sorting on the record number (NUMBER or .001), the piece will contain
 ;;^DD(.4014,2,21,4,0)
 ;;=a 0.
 ;;^DD(.4014,2,23,0)
 ;;=^^1^1^2930125^
 ;;^DD(.4014,2,23,1,0)
 ;;=Created by FileMan during the print option (in the DIP* routines).
 ;;^DD(.4014,2,"DT")
 ;;=2930125
 ;;^DD(.4014,3,0)
 ;;=FIELD NAME^F^^0;3^K:$L(X)>100!($L(X)<1) X
 ;;^DD(.4014,3,3)
 ;;=Answer must be 1-100 characters in length.
 ;;^DD(.4014,3,21,0)
 ;;=^^2^2^2930125^
 ;;^DD(.4014,3,21,1,0)
 ;;=This piece contains the sort field name, or the user entry if sorting by
 ;;^DD(.4014,3,21,2,0)
 ;;=an on-the-fly computed field.
 ;;^DD(.4014,3,23,0)
 ;;=^^1^1^2930125^
 ;;^DD(.4014,3,23,1,0)
 ;;=Created by FileMan during the print option (DIP* routines).
 ;;^DD(.4014,3,"DT")
 ;;=2930125
 ;;^DD(.4014,4,0)
 ;;=SORT QUALIFIERS BEFORE FIELD^F^^0;4^K:$L(X)>20!($L(X)<1) X
 ;;^DD(.4014,4,3)
 ;;=Answer must be 1-20 characters in length.  Sort qualifiers that normally precede the field number in the user dialogue (like !,@,#,+)
 ;;^DD(.4014,4,21,0)
 ;;=^^5^5^2930125^^^
 ;;^DD(.4014,4,21,1,0)
 ;;=This contains all of the sort qualifiers that normally precede the field
 ;;^DD(.4014,4,21,2,0)
 ;;=number in the user dialogue during the sort option.  It includes things
 ;;^DD(.4014,4,21,3,0)
 ;;=like # (Page break when sort value changes), @ (suppress printing of
 ;;^DD(.4014,4,21,4,0)
 ;;=subheader).  These qualifiers are listed out with no delimiters, as they
 ;;^DD(.4014,4,21,5,0)
 ;;=are found during the user dialogue.  (So you might see something like #@).
 ;;^DD(.4014,4,23,0)
 ;;=^^2^2^2930125^^
 ;;^DD(.4014,4,23,1,0)
 ;;=This information is parsed from the user dialogue or from the BY
 ;;^DD(.4014,4,23,2,0)
 ;;=input variable, by the FileMan print routines DIP*.
 ;;^DD(.4014,4,"DT")
 ;;=2930125
 ;;^DD(.4014,4.1,0)
 ;;=SORT QUALIFIERS AFTER FIELD^F^^0;5^K:$L(X)>70!($L(X)<1) X
 ;;^DD(.4014,4.1,3)
 ;;=Answer must be 1-70 characters in length.  Sort qualifiers that normally come after the field in the user dialogue (such as ;Cn, ;Ln, ;"Literal Subheader")

DINIT122
DINIT122 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:14
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4014,4.1,21,0)
 ;;=^^6^6^2930125^
 ;;^DD(.4014,4.1,21,1,0)
 ;;=This contains all of the sort qualifiers that normally come after the
 ;;^DD(.4014,4.1,21,2,0)
 ;;=field number in the user dialogue for the sort options.  It includes
 ;;^DD(.4014,4.1,21,3,0)
 ;;=things like ;Cn (specify position of subheader) and ;"literal" to
 ;;^DD(.4014,4.1,21,4,0)
 ;;=replace the caption of the subheader.  These qualifiers are listed with
 ;;^DD(.4014,4.1,21,5,0)
 ;;=no delimiters, as they are found in the user dialogue.  (So you might see
 ;;^DD(.4014,4.1,21,6,0)
 ;;=something like ;C10;"My Subheader").
 ;;^DD(.4014,4.1,23,0)
 ;;=^^2^2^2930125^
 ;;^DD(.4014,4.1,23,1,0)
 ;;=This information is parsed from the user dialogue or from the BY
 ;;^DD(.4014,4.1,23,2,0)
 ;;=input variable, by the FileMan print routines DIP*.
 ;;^DD(.4014,4.1,"DT")
 ;;=2930125
 ;;^DD(.4014,4.2,0)
 ;;=COMPUTED FIELD TYPE^F^^0;7^K:$L(X)>10!($L(X)<1) X
 ;;^DD(.4014,4.2,3)
 ;;=Answer must be 1-10 characters in length.  Set by the print routine to something that looks like second piece of 0 node of DD (data type information) for on-the-fly computed fields or .001 field.
 ;;^DD(.4014,4.2,21,0)
 ;;=^^4^4^2931022^
 ;;^DD(.4014,4.2,21,1,0)
 ;;=This piece will contain a "D" if on-the-fly computed field results in a
 ;;^DD(.4014,4.2,21,2,0)
 ;;=date.  It will be set to something like NJ6,0 if sorting by the .001
 ;;^DD(.4014,4.2,21,3,0)
 ;;=field. (These are the only values I have been able to find for this
 ;;^DD(.4014,4.2,21,4,0)
 ;;=field.)
 ;;^DD(.4014,4.2,23,0)
 ;;=^^3^3^2931022^
 ;;^DD(.4014,4.2,23,1,0)
 ;;=Set in C^DIP0 if DICOMP tells us that an on-the-fly computed field will
 ;;^DD(.4014,4.2,23,2,0)
 ;;=result in a date, and in ^DIP is sorting by the .001 field on a file that
 ;;^DD(.4014,4.2,23,3,0)
 ;;=has one.
 ;;^DD(.4014,4.2,"DT")
 ;;=2931022
 ;;^DD(.4014,4.3,0)
 ;;=ASK FOR FROM AND TO^S^1:YES;^ASK;1^Q
 ;;^DD(.4014,4.3,3)
 ;;=Enter 1 (YES) if user is to be prompted for FROM/TO values for this SORT FIELD.
 ;;^DD(.4014,4.3,21,0)
 ;;=^^3^3^2930201^
 ;;^DD(.4014,4.3,21,1,0)
 ;;=If this node is defined: then when the PRINT Option is run, or during
 ;;^DD(.4014,4.3,21,2,0)
 ;;=a call to the programmer print EN1^DIP, the user will be prompted
 ;;^DD(.4014,4.3,21,3,0)
 ;;=for FROM and TO VALUES for this sort field.
 ;;^DD(.4014,4.3,23,0)
 ;;=^^4^4^2930201^
 ;;^DD(.4014,4.3,23,1,0)
 ;;=This field is created automatically when a template is being created or
 ;;^DD(.4014,4.3,23,2,0)
 ;;=edited, if the developer enters FROM/TO values, AND if the developer
 ;;^DD(.4014,4.3,23,3,0)
 ;;=then answers YES to the question "SHOULD TEMPLATE USER BE ASKED
 ;;^DD(.4014,4.3,23,4,0)
 ;;='FROM'-'TO' RANGE FOR field?"
 ;;^DD(.4014,4.3,"DT")
 ;;=2930201
 ;;^DD(.4014,5,0)
 ;;=FROM VALUE INTERNAL^F^^F;1^K:$L(X)>63!($L(X)<1) X
 ;;^DD(.4014,5,3)
 ;;=Answer must be 1-63 characters in length.  The starting point for the sort, derived by FileMan.
 ;;^DD(.4014,5,21,0)
 ;;=^^3^3^2930119^^
 ;;^DD(.4014,5,21,1,0)
 ;;=FileMan takes the FROM value entered by the user, and finds the first
 ;;^DD(.4014,5,21,2,0)
 ;;=value that will sort just before this value in order to derive the
 ;;^DD(.4014,5,21,3,0)
 ;;=starting point for the sort.
 ;;^DD(.4014,5,23,0)
 ;;=^^1^1^2930119^^
 ;;^DD(.4014,5,23,1,0)
 ;;=Calculated by the sort routine FRV^DIP1.
 ;;^DD(.4014,5,"DT")
 ;;=2930119
 ;;^DD(.4014,6,0)
 ;;=FROM VALUE EXTERNAL^F^^F;2^K:$L(X)>63!($L(X)<1) X
 ;;^DD(.4014,6,3)
 ;;=Answer must be 1-63 characters in length.  The starting point for the sort, as entered by the user.
 ;;^DD(.4014,6,21,0)
 ;;=^^1^1^2930115^
 ;;^DD(.4014,6,21,1,0)
 ;;=The FROM value for the sort, as it was entered by the user.
 ;;^DD(.4014,6,"DT")
 ;;=2930119
 ;;^DD(.4014,6.5,0)
 ;;=FROM VALUE PRINTABLE^F^^F;3^K:$L(X)>40!($L(X)<1) X
 ;;^DD(.4014,6.5,3)
 ;;=Answer must be 1-40 characters in length.  Used for storing printable form of date or set values.
 ;;^DD(.4014,6.5,21,0)
 ;;=^^3^3^2930216^^
 ;;^DD(.4014,6.5,21,1,0)
 ;;=This field is used to store a printable representation of the FROM value
 ;;^DD(.4014,6.5,21,2,0)
 ;;=entered by the user during the sort/print dialogue.  Used for date and
 ;;^DD(.4014,6.5,21,3,0)
 ;;=set-of-code data types.
 ;;^DD(.4014,6.5,23,0)
 ;;=^^1^1^2930216^
 ;;^DD(.4014,6.5,23,1,0)
 ;;=Built in CK^DIP12.
 ;;^DD(.4014,6.5,"DT")
 ;;=2930216
 ;;^DD(.4014,7,0)
 ;;=TO VALUE INTERNAL^F^^T;1^K:$L(X)>63!($L(X)<1) X

DINIT123
DINIT123 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:15
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4014,7,3)
 ;;=Answer must be 1-63 characters in length.  The ending point for the sort, derived by FileMan.
 ;;^DD(.4014,7,21,0)
 ;;=^^3^3^2930115^
 ;;^DD(.4014,7,21,1,0)
 ;;=FileMan usually uses the TO value as entered by the user, but in the
 ;;^DD(.4014,7,21,2,0)
 ;;=case of dates and sets of codes, the internal value is used.  This field
 ;;^DD(.4014,7,21,3,0)
 ;;=tells FileMan the ending point for the sort.
 ;;^DD(.4014,7,"DT")
 ;;=2930119
 ;;^DD(.4014,8,0)
 ;;=TO VALUE EXTERNAL^F^^T;2^K:$L(X)>63!($L(X)<1) X
 ;;^DD(.4014,8,3)
 ;;=Answer must be 1-63 characters in length.  The ending point for the sort, as entered by the user.
 ;;^DD(.4014,8,21,0)
 ;;=^^1^1^2930115^
 ;;^DD(.4014,8,21,1,0)
 ;;=The ending value for the sort, as entered by the user.
 ;;^DD(.4014,8,"DT")
 ;;=2930119
 ;;^DD(.4014,8.5,0)
 ;;=TO VALUE PRINTABLE^F^^T;3^K:$L(X)>40!($L(X)<1) X
 ;;^DD(.4014,8.5,3)
 ;;=Answer must be 1-40 characters in length.  Used for storing printable form of date and set values.
 ;;^DD(.4014,8.5,21,0)
 ;;=^^3^3^2930216^
 ;;^DD(.4014,8.5,21,1,0)
 ;;=This field is used to store a printable representation of the TO value
 ;;^DD(.4014,8.5,21,2,0)
 ;;=entered by the user during the sort/print dialogue.  Used for date and
 ;;^DD(.4014,8.5,21,3,0)
 ;;=set-of-code data types.
 ;;^DD(.4014,8.5,23,0)
 ;;=^^1^1^2930216^
 ;;^DD(.4014,8.5,23,1,0)
 ;;=Created in CK^DIP12.
 ;;^DD(.4014,8.5,"DT")
 ;;=2930216
 ;;^DD(.4014,9,0)
 ;;=CROSS REFERENCE DATA^F^^IX;E1,245^K:$L(X)>245!($L(X)<1) X
 ;;^DD(.4014,9,3)
 ;;=First ^ piece null, second piece=static part of cross-reference, third piece=global reference, 4th piece=number of variable subscripts to get to (and including) record number.
 ;;^DD(.4014,9,21,0)
 ;;=^^8^8^2930115^
 ;;^DD(.4014,9,21,1,0)
 ;;= Piece 1 is always null
 ;;^DD(.4014,9,21,2,0)
 ;;= Piece 2 is the static part of the cross-reference: ex. DIZ(662001,"B",
 ;;^DD(.4014,9,21,3,0)
 ;;= Piece 3 is the global reference: ex. DIZ(662001,
 ;;^DD(.4014,9,21,4,0)
 ;;= Piece 4 tells FileMan how many variable subscripts must be sorted
 ;;^DD(.4014,9,21,5,0)
 ;;=through to get to the record number, plus 1 for the record number
 ;;^DD(.4014,9,21,6,0)
 ;;=itself.  ex. for a regular cross-reference, ^DIZ(662001,"B",X,DA),
 ;;^DD(.4014,9,21,7,0)
 ;;=the number is 2.  One for the value of the X subscript, and one for the
 ;;^DD(.4014,9,21,8,0)
 ;;=record number itself (DA).
 ;;^DD(.4014,9,23,0)
 ;;=^^6^6^2930115^
 ;;^DD(.4014,9,23,1,0)
 ;;=The IX nodes are normally derived by FileMan during the entry of sort
 ;;^DD(.4014,9,23,2,0)
 ;;=fields (in routine XR^DIP).  However, they can also be passed to the
 ;;^DD(.4014,9,23,3,0)
 ;;=print (^DIP) in the BY(0) variable to cause FileMan to either use a MUMPS
 ;;^DD(.4014,9,23,4,0)
 ;;=type cross-reference, or a previously sorted list of record numbers.
 ;;^DD(.4014,9,23,5,0)
 ;;=Fileman sometimes builds the IX node prior to calling the print, as in
 ;;^DD(.4014,9,23,6,0)
 ;;=the INQUIRE option, where the user then goes on to print the records.
 ;;^DD(.4014,9,"DT")
 ;;=2930115
 ;;^DD(.4014,9.5,0)
 ;;=POINT TO CROSS REFERENCE^F^^PTRIX;E1,245^K:$L(X)>245!($L(X)<1) X
 ;;^DD(.4014,9.5,3)
 ;;=Enter global reference for "B" index of .01 field on pointed-to file.  Answer must be 1-245 characters in length.
 ;;^DD(.4014,9.5,21,0)
 ;;=^^7^7^2931221^
 ;;^DD(.4014,9.5,21,1,0)
 ;;=This node will exist only if the sort field is a pointer, if the sort
 ;;^DD(.4014,9.5,21,2,0)
 ;;=field has a regular cross-reference, if the .01 field on the pointed-to
 ;;^DD(.4014,9.5,21,3,0)
 ;;=file has a "B" index, and if the .01 field on the pointed-to file is
 ;;^DD(.4014,9.5,21,4,0)
 ;;=either a numeric, date, set-of-codes or free-text field, and does not have
 ;;^DD(.4014,9.5,21,5,0)
 ;;=an output transform.  If this node exists, it will be set to the static
 ;;^DD(.4014,9.5,21,6,0)
 ;;=part of the global reference of the "B" index on the pointed-to file. (ex.
 ;;^DD(.4014,9.5,21,7,0)
 ;;=^DIZ(662001,"B",).
 ;;^DD(.4014,9.5,"DT")
 ;;=2931221
 ;;^DD(.4014,10,0)
 ;;=GET CODE^K^^GET;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4014,10,3)
 ;;=This is Standard MUMPS code used to extract the sort field from a record.
 ;;^DD(.4014,10,9)
 ;;=@
 ;;^DD(.4014,10,21,0)
 ;;=^^3^3^2930115^
 ;;^DD(.4014,10,21,1,0)
 ;;=The GET CODE is MUMPS code that is executed after a record (or sub-record)

DINIT124
DINIT124 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:16
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4014,10,21,2,0)
 ;;=has been selected.  The code extracts the SORT field from that record
 ;;^DD(.4014,10,21,3,0)
 ;;=into a local variable.
 ;;^DD(.4014,10,23,0)
 ;;=^^1^1^2930115^
 ;;^DD(.4014,10,23,1,0)
 ;;=GET CODE can be generated by a call to FileMan routine GET^DIOU.
 ;;^DD(.4014,10,"DT")
 ;;=2930115
 ;;^DD(.4014,11,0)
 ;;=QUERY CONDITION^K^^QCON;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4014,11,3)
 ;;=This is Standard MUMPS code used to test the field to see whether it meets the query condition (ex., whether it's within the from/to range specified by the user).
 ;;^DD(.4014,11,9)
 ;;=@
 ;;^DD(.4014,11,21,0)
 ;;=^^5^5^2930115^
 ;;^DD(.4014,11,21,1,0)
 ;;=The QUERY CONDITION is MUMPS code that takes a field in a local variable,
 ;;^DD(.4014,11,21,2,0)
 ;;=and executes some query condition.  The results of executing the code
 ;;^DD(.4014,11,21,3,0)
 ;;=will return a truth value of TRUE if the field met the condition, or
 ;;^DD(.4014,11,21,4,0)
 ;;=FALSE if not.  It is used, for example, to see whether a SORT FIELD falls
 ;;^DD(.4014,11,21,5,0)
 ;;=within the FROM/TO range requested by the user.
 ;;^DD(.4014,11,23,0)
 ;;=^^2^2^2930115^
 ;;^DD(.4014,11,23,1,0)
 ;;=The QUERY CONDITION code is generated by various calls to FileMan
 ;;^DD(.4014,11,23,2,0)
 ;;=routines DIOC*.
 ;;^DD(.4014,11,"DT")
 ;;=2930115
 ;;^DD(.4014,12,0)
 ;;=DESCRIPTION OF SORT^F^^TXT;E1,200^K:$L(X)>200!($L(X)<1) X
 ;;^DD(.4014,12,3)
 ;;=Answer must be 1-200 characters in length.  Text explaining the query condition (field name and what conditions must be met in order for the record to be selected).
 ;;^DD(.4014,12,21,0)
 ;;=^^4^4^2930115^
 ;;^DD(.4014,12,21,1,0)
 ;;=This field contains a brief textual description of the SORT FIELD and
 ;;^DD(.4014,12,21,2,0)
 ;;=the SORT CRITERIA used on it (i.e., the from/to values).  This
 ;;^DD(.4014,12,21,3,0)
 ;;=description can be printed in the heading of a report, at the users
 ;;^DD(.4014,12,21,4,0)
 ;;=request.
 ;;^DD(.4014,12,23,0)
 ;;=^^2^2^2930115^
 ;;^DD(.4014,12,23,1,0)
 ;;=This text is build as the developer answers the FROM/TO questions
 ;;^DD(.4014,12,23,2,0)
 ;;=during the SORT sequence.
 ;;^DD(.4014,12,"DT")
 ;;=2930115
 ;;^DD(.4014,13,0)
 ;;=SEARCH EFFICIENCY RATING^NJ9,4^^SER;1^K:+X'=X!(X>9999.9999)!(X<0)!(X?.E1"."5N.N) X
 ;;^DD(.4014,13,3)
 ;;=Type a Number between 0 and 9999.9999, 4 Decimal Digits.  Search efficiency number returned by Query Optimizer Routine.
 ;;^DD(.4014,13,21,0)
 ;;=^^7^7^2930125^
 ;;^DD(.4014,13,21,1,0)
 ;;=Fields are assigned a search efficiency rating based on the number of
 ;;^DD(.4014,13,21,2,0)
 ;;=hits found for the query (or sort) condition.  The fewer the hits, the
 ;;^DD(.4014,13,21,3,0)
 ;;=higher the rating.  A high rating indicates the criteria will more quickly
 ;;^DD(.4014,13,21,4,0)
 ;;=cut down the number of records to be processed.  The rating will be
 ;;^DD(.4014,13,21,5,0)
 ;;=higher if the field has a cross-reference.  The field with the highest
 ;;^DD(.4014,13,21,6,0)
 ;;=rating is used to do the initial loop through the file during the sort
 ;;^DD(.4014,13,21,7,0)
 ;;=phase.
 ;;^DD(.4014,13,23,0)
 ;;=^^1^1^2930125^
 ;;^DD(.4014,13,23,1,0)
 ;;=Calculated in the Query Optimizer routine ^DIOQ.
 ;;^DD(.4014,13,"DT")
 ;;=2930125
 ;;^DD(.4014,14,0)
 ;;=PROBABILITY RATING^NJ9,4^^SER;2^K:+X'=X!(X>9999.9999)!(X<0)!(X?.E1"."5N.N) X
 ;;^DD(.4014,14,3)
 ;;=Type a Number between 0 and 9999.9999, 4 Decimal Digits.  Probability of field meeting the sort criteria--returned by Query Optimizer routine.
 ;;^DD(.4014,14,21,0)
 ;;=^^6^6^2930125^^
 ;;^DD(.4014,14,21,1,0)
 ;;=Fields are assigned a probability rating based on the number of hits
 ;;^DD(.4014,14,21,2,0)
 ;;=found for the query (or sort) condition.  The probability rating is used
 ;;^DD(.4014,14,21,3,0)
 ;;=to determine the order in which query conditions should be executed
 ;;^DD(.4014,14,21,4,0)
 ;;=during the sort phase.  Fields with a higher probability rating are
 ;;^DD(.4014,14,21,5,0)
 ;;=executed first to most quickly cut down the number of records that have
 ;;^DD(.4014,14,21,6,0)
 ;;=to be processed.
 ;;^DD(.4014,14,23,0)
 ;;=^^1^1^2930125^
 ;;^DD(.4014,14,23,1,0)
 ;;=Calculated by a call to the FileMan Query Optimizer routine ^DIOQ.
 ;;^DD(.4014,14,"DT")
 ;;=2930125
 ;;^DD(.4014,15,0)
 ;;=DATA TYPE FOR SORTING^P.81'^DI(.81,^0;10^Q
 ;;^DD(.4014,15,21,0)
 ;;=^^5^5^2930514^

DINIT125
DINIT125 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:16
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4014,15,21,1,0)
 ;;=This pointer to the FileMan DATA TYPE file is entered automatically by
 ;;^DD(.4014,15,21,2,0)
 ;;=FileMan during the sort/print.  Note that if sorting by a pointer or a
 ;;^DD(.4014,15,21,3,0)
 ;;=variable pointer, FileMan will follow the pointer chain until it gets to
 ;;^DD(.4014,15,21,4,0)
 ;;=one of the other data types, in order to determine how to correctly set up
 ;;^DD(.4014,15,21,5,0)
 ;;=the sort logic.
 ;;^DD(.4014,15,23,0)
 ;;=^^1^1^2930514^
 ;;^DD(.4014,15,23,1,0)
 ;;=Pointer to DATA TYPE file, derived by FileMan in routine DTYP^DIP1.
 ;;^DD(.4014,15,"DT")
 ;;=2930514
 ;;^DD(.4014,16,0)
 ;;=COMPUTED FIELD CODE^K^^CM;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4014,16,3)
 ;;=This is Standard MUMPS code, generated for sorting by computed fields or pointer fields.
 ;;^DD(.4014,16,9)
 ;;=@
 ;;^DD(.4014,16,21,0)
 ;;=^^3^3^2930201^
 ;;^DD(.4014,16,21,1,0)
 ;;=This field contains MUMPS code used to find the actual value of a field
 ;;^DD(.4014,16,21,2,0)
 ;;=that is computed or a pointer.  The code is generated by DICOMP.  This
 ;;^DD(.4014,16,21,3,0)
 ;;=code may execute code in OVERFLOW nodes as well.
 ;;^DD(.4014,16,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.4014,16,23,1,0)
 ;;=Generated by DICOMP.  Put into the DPP array in C^DIP0.
 ;;^DD(.4014,16,"DT")
 ;;=2930201
 ;;^DD(.4014,17,0)
 ;;=MULTIPLE FIELD DATA^.40141^^1;0
 ;;^DD(.4014,18,0)
 ;;=RELATIONAL JUMP FIELD DATA^.401418^^2;0
 ;;^DD(.4014,19,0)
 ;;=OVERFLOW DATA^.401419^^3;0
 ;;^DD(.4014,19,21,0)
 ;;=^^5^5^2930201^
 ;;^DD(.4014,19,21,1,0)
 ;;=This field contains the first subscript from the part of the DPP array
 ;;^DD(.4014,19,21,2,0)
 ;;=that contains overflow code executed when sorting by a field that is
 ;;^DD(.4014,19,21,3,0)
 ;;=gotten to relationally or a computed field.  Overflow code is generated
 ;;^DD(.4014,19,21,4,0)
 ;;=when needed by DICOMP.  This field will typically look something like
 ;;^DD(.4014,19,21,5,0)
 ;;="OVF0".
 ;;^DD(.4014,19,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.4014,19,23,1,0)
 ;;=Generated by DICOMP from DIP0 during the sort/print option.
 ;;^DD(.4014,19,"DT")
 ;;=2930201
 ;;^DD(.4014,20,0)
 ;;=SUBHEADER OUTPUT TRANSFORM^K^^OUT;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4014,20,3)
 ;;=This is Standard MUMPS code.  This is used only when sorting by a user-specified cross-reference in input variable BY(0).
 ;;^DD(.4014,20,9)
 ;;=@
 ;;^DD(.4014,20,21,0)
 ;;=^^6^6^2930204^
 ;;^DD(.4014,20,21,1,0)
 ;;=Defined only when using the BY(0) input variable to the FileMan print,
 ;;^DD(.4014,20,21,2,0)
 ;;=EN1^DIP, which allows the user to specify a cross-reference to sort on.
 ;;^DD(.4014,20,21,3,0)
 ;;=The user is allowed to specify MUMPS code that can be used as an output
 ;;^DD(.4014,20,21,4,0)
 ;;=transform for any of the subheaders (i.e., subscripts in the
 ;;^DD(.4014,20,21,5,0)
 ;;=cross-reference) in the S input array.  This output transform code is
 ;;^DD(.4014,20,21,6,0)
 ;;=stored in this field.
 ;;^DD(.4014,20,23,0)
 ;;=^^4^4^2930204^
 ;;^DD(.4014,20,23,1,0)
 ;;=Stores output transform code from the third piece of S(0,N) where N is
 ;;^DD(.4014,20,23,2,0)
 ;;=the sort level.  This is an input array used in conjunction with BY(0)
 ;;^DD(.4014,20,23,3,0)
 ;;=when user specifies a specific cross-reference to use for the sort, in
 ;;^DD(.4014,20,23,4,0)
 ;;=in the FileMan print routine EN1^DIP.
 ;;^DD(.4014,20,"DT")
 ;;=2930204
 ;;^DD(.4014,21,0)
 ;;=TEXT SORT FLAG^S^SORT:SORT LIKE TEXT;RANGE:TREAT RANGE LIKE TEXT;^SRTTXT;1^Q
 ;;^DD(.4014,21,21,0)
 ;;=^^12^12^2931221^
 ;;^DD(.4014,21,21,1,0)
 ;;=This flag will be set in one of two cases.
 ;;^DD(.4014,21,21,2,0)
 ;;= 1) If the user entered the ;TXT qualifier, the flag will be set to
 ;;^DD(.4014,21,21,3,0)
 ;;="SORT", and will cause a space to be inserted at the beginning of each
 ;;^DD(.4014,21,21,4,0)
 ;;=sort value, causing even numeric fields to be sorted as if they were text.
 ;;^DD(.4014,21,21,5,0)
 ;;= 2) If the user entered a FROM or TO value that is a non-canonic number,
 ;;^DD(.4014,21,21,6,0)
 ;;=the flag will be set to RANGE, and will cause sort values that are numeric
 ;;^DD(.4014,21,21,7,0)
 ;;=to be treated as if they were text, when seeing whether they fall within
 ;;^DD(.4014,21,21,8,0)
 ;;=the from/to range.  However, they will still sort like numbers (MUMPS sort
 ;;^DD(.4014,21,21,9,0)
 ;;=sequence).
 ;;^DD(.4014,21,21,10,0)
 ;;= 

DINIT126
DINIT126 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:17
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4014,21,21,11,0)
 ;;=The flag is set automatically when the user is entering the sort fields in
 ;;^DD(.4014,21,21,12,0)
 ;;=^DIP, and the from/to values in ^DIP1.
 ;;^DD(.4014,21,"DT")
 ;;=2931221
 ;;^DD(.40141,0)
 ;;=MULTIPLE FIELD DATA SUB-FIELD^^1^2
 ;;^DD(.40141,0,"DT")
 ;;=2930201
 ;;^DD(.40141,0,"IX","B",.40141,.01)
 ;;=
 ;;^DD(.40141,0,"NM","MULTIPLE FIELD DATA")
 ;;=
 ;;^DD(.40141,0,"UP")
 ;;=.4014
 ;;^DD(.40141,.01,0)
 ;;=MULT.FILE OR SUBFILE NO.^MNJ13,5^^0;1^K:+X'=X!(X>9999999.99999)!(X<0)!(X?.E1"."6N.N) X
 ;;^DD(.40141,.01,1,0)
 ;;=^.1
 ;;^DD(.40141,.01,1,1,0)
 ;;=.40141^B
 ;;^DD(.40141,.01,1,1,1)
 ;;=S ^DIBT(DA(2),2,DA(1),1,"B",$E(X,1,30),DA)=""
 ;;^DD(.40141,.01,1,1,2)
 ;;=K ^DIBT(DA(2),2,DA(1),1,"B",$E(X,1,30),DA)
 ;;^DD(.40141,.01,3)
 ;;=Type a Number between 0 and 9999999.99999, 5 Decimal Digits.  This is the file/subfile number when sorting by a multiple field.
 ;;^DD(.40141,.01,21,0)
 ;;=^^4^4^2930201^
 ;;^DD(.40141,.01,21,1,0)
 ;;=All files or subfiles needed to get back up to the top level from a
 ;;^DD(.40141,.01,21,2,0)
 ;;=multiple field will be represented by an entry in this field.  The
 ;;^DD(.40141,.01,21,3,0)
 ;;=file or subfile number will be used as a subscript in the DPP array
 ;;^DD(.40141,.01,21,4,0)
 ;;=during the sort/print processing.
 ;;^DD(.40141,.01,"DT")
 ;;=2930201
 ;;^DD(.40141,1,0)
 ;;=NODE^F^^0;2^K:$L(X)>50!($L(X)<1) X
 ;;^DD(.40141,1,3)
 ;;=Answer must be 1-50 characters in length.  This is the node from which the data is descendant.
 ;;^DD(.40141,1,21,0)
 ;;=^^1^1^2930201^
 ;;^DD(.40141,1,21,1,0)
 ;;=This field contains the node from which the multiple data is descendant.
 ;;^DD(.40141,1,"DT")
 ;;=2930201
 ;;^DD(.401418,0)
 ;;=RELATIONAL JUMP FIELD DATA SUB-FIELD^^5^6
 ;;^DD(.401418,0,"DT")
 ;;=2930201
 ;;^DD(.401418,0,"IX","B",.401418,.01)
 ;;=
 ;;^DD(.401418,0,"NM","RELATIONAL JUMP FIELD DATA")
 ;;=
 ;;^DD(.401418,0,"UP")
 ;;=.4014
 ;;^DD(.401418,.01,0)
 ;;=RELATIONAL START FILE NO.^MNJ13,5^^0;1^K:+X'=X!(X>9999999.99999)!(X<0)!(X?.E1"."6N.N) X
 ;;^DD(.401418,.01,1,0)
 ;;=^.1
 ;;^DD(.401418,.01,1,1,0)
 ;;=.401418^B
 ;;^DD(.401418,.01,1,1,1)
 ;;=S ^DIBT(DA(2),2,DA(1),2,"B",$E(X,1,30),DA)=""
 ;;^DD(.401418,.01,1,1,2)
 ;;=K ^DIBT(DA(2),2,DA(1),2,"B",$E(X,1,30),DA)
 ;;^DD(.401418,.01,3)
 ;;=Type a Number between 0 and 9999999.99999, 5 Decimal Digits
 ;;^DD(.401418,.01,21,0)
 ;;=^^3^3^2930201^^^^
 ;;^DD(.401418,.01,21,1,0)
 ;;=Data will appear here if sorting by a field that must be gotten to using
 ;;^DD(.401418,.01,21,2,0)
 ;;=a relational jump.  This will be the file or subfile number from which
 ;;^DD(.401418,.01,21,3,0)
 ;;=the user is jumping (i.e., the starting point).
 ;;^DD(.401418,.01,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401418,.01,23,1,0)
 ;;=Built in COLON^DIP0 during the sort/print.
 ;;^DD(.401418,.01,"DT")
 ;;=2930201
 ;;^DD(.401418,1,0)
 ;;=NEXT SUBSCRIPT^RNJ7,0^^0;2^K:+X'=X!(X>9999999)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(.401418,1,3)
 ;;=Type a Number between 0 and 9999999, 0 Decimal Digits.  Subscript used in the DPP array during the sort/print option.
 ;;^DD(.401418,1,21,0)
 ;;=^^4^4^2930201^
 ;;^DD(.401418,1,21,1,0)
 ;;=This field contains a subscript used n the DPP array during the
 ;;^DD(.401418,1,21,2,0)
 ;;=sort/print.  The subscript is generated by DICOMP (using the level
 ;;^DD(.401418,1,21,3,0)
 ;;=number multiplied by 100 I think).  It results in building a node
 ;;^DD(.401418,1,21,4,0)
 ;;=like DPP(DJ,file/subfile no.,subscript)=data.
 ;;^DD(.401418,1,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401418,1,23,1,0)
 ;;=Built by COLON^DIP0 routine.
 ;;^DD(.401418,1,"DT")
 ;;=2930201
 ;;^DD(.401418,2,0)
 ;;=TO FILE OR SUBFILE^NJ13,5^^0;3^K:+X'=X!(X>9999999.99999)!(X<0)!(X?.E1"."6N.N) X
 ;;^DD(.401418,2,3)
 ;;=Type a Number between 0 and 9999999.99999, 5 Decimal Digits.  The file or subfile number to which we are jumping using a relational jump.
 ;;^DD(.401418,2,21,0)
 ;;=^^2^2^2930201^
 ;;^DD(.401418,2,21,1,0)
 ;;=This field contains the file or subfile number to which we are making
 ;;^DD(.401418,2,21,2,0)
 ;;=the relational jump (i.e., the destination file).
 ;;^DD(.401418,2,23,0)
 ;;=^^1^1^2930201^^
 ;;^DD(.401418,2,23,1,0)
 ;;=Built in COLON^DIP0 during the sort/print.
 ;;^DD(.401418,2,"DT")
 ;;=2930201
 ;;^DD(.401418,3,0)
 ;;=GLOBAL REFERENCE^F^^0;4^K:$L(X)>50!($L(X)<1) X
 ;;^DD(.401418,3,3)
 ;;=Answer must be 1-50 characters in length.  Contains the global reference of the file to which we are jumping relationally.

DINIT127
DINIT127 ;SFISC/TKW - INITIALIZE V21 SORT TEMPLATE DD NODES ;6/24/94  11:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.401418,3,21,0)
 ;;=^^2^2^2930201^
 ;;^DD(.401418,3,21,1,0)
 ;;=This field contains the global reference of the file to which we are
 ;;^DD(.401418,3,21,2,0)
 ;;=jumping relationally (i.e., the destination file).
 ;;^DD(.401418,3,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401418,3,23,1,0)
 ;;=Built by COLON^DIP0 during the sort/print option.
 ;;^DD(.401418,3,"DT")
 ;;=2930201
 ;;^DD(.401418,4,0)
 ;;=MULTIVALUED FLAG^S^0:NOT MULTI-VALUED;1:YES, MULTI-VALUED;^0;5^Q
 ;;^DD(.401418,4,21,0)
 ;;=^^6^6^2930201^
 ;;^DD(.401418,4,21,1,0)
 ;;=This flag indicates whether the relational jump will result in going to
 ;;^DD(.401418,4,21,2,0)
 ;;=a file that has a many-to-one relationship to the starting (home) file
 ;;^DD(.401418,4,21,3,0)
 ;;=(i.e., a jump to a backwards pointer) or a one-to-one relationship (i.e.,
 ;;^DD(.401418,4,21,4,0)
 ;;=a forwards pointer jump).  The flag will be set to 1 to indicate that
 ;;^DD(.401418,4,21,5,0)
 ;;=that there is a many-to-one or multi-valued relationship to the home
 ;;^DD(.401418,4,21,6,0)
 ;;=file, or to 0 if not.
 ;;^DD(.401418,4,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401418,4,23,1,0)
 ;;=Set in COLON^DIP0 during the sort/print option.
 ;;^DD(.401418,4,"DT")
 ;;=2930201
 ;;^DD(.401418,5,0)
 ;;=RELATIONAL CODE^K^^RCOD;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.401418,5,3)
 ;;=This is Standard MUMPS code, used to make a relational jump.
 ;;^DD(.401418,5,9)
 ;;=@
 ;;^DD(.401418,5,21,0)
 ;;=^^2^2^2930201^
 ;;^DD(.401418,5,21,1,0)
 ;;=This is the MUMPS code needed to perform the relational jump during the
 ;;^DD(.401418,5,21,2,0)
 ;;=sort part of the sort/print option.
 ;;^DD(.401418,5,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401418,5,23,1,0)
 ;;=Generated from COLON^DIP0 during the sort/print option.
 ;;^DD(.401418,5,"DT")
 ;;=2930201
 ;;^DD(.401419,0)
 ;;=OVERFLOW DATA SUB-FIELD^^2^3
 ;;^DD(.401419,0,"DT")
 ;;=2930201
 ;;^DD(.401419,0,"IX","B",.401419,.01)
 ;;=
 ;;^DD(.401419,0,"NM","OVERFLOW DATA")
 ;;=
 ;;^DD(.401419,0,"UP")
 ;;=.4014
 ;;^DD(.401419,.01,0)
 ;;=FIRST SUBSCRIPT FOR OVERFLOW^MF^^0;1^K:$L(X)>20!($L(X)<1) X
 ;;^DD(.401419,.01,1,0)
 ;;=^.1
 ;;^DD(.401419,.01,1,1,0)
 ;;=.401419^B
 ;;^DD(.401419,.01,1,1,1)
 ;;=S ^DIBT(DA(2),2,DA(1),3,"B",$E(X,1,30),DA)=""
 ;;^DD(.401419,.01,1,1,2)
 ;;=K ^DIBT(DA(2),2,DA(1),3,"B",$E(X,1,30),DA)
 ;;^DD(.401419,.01,3)
 ;;=Answer must be 1-20 characters in length.  This multiple contains overflow code needed for sorting by relational or computed fields.
 ;;^DD(.401419,.01,"DT")
 ;;=2930201
 ;;^DD(.401419,1,0)
 ;;=SECOND SUBSCRIPT FOR OVERFLOW^NJ10,4^^0;2^K:+X'=X!(X>99999.9999)!(X<0)!(X?.E1"."5N.N) X
 ;;^DD(.401419,1,3)
 ;;=Type a Number between 0 and 99999.9999, 4 Decimal Digits
 ;;^DD(.401419,1,21,0)
 ;;=^^4^4^2930201^
 ;;^DD(.401419,1,21,1,0)
 ;;=This field contains the second subscript from the part of the DPP array
 ;;^DD(.401419,1,21,2,0)
 ;;=that contains overflow code executed when sorting by a field that is
 ;;^DD(.401419,1,21,3,0)
 ;;=gotten to relationally or a computed field.  Overflow code is generated
 ;;^DD(.401419,1,21,4,0)
 ;;=when needed by DICOMP.  This field will typically look something like 9.2.
 ;;^DD(.401419,1,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401419,1,23,1,0)
 ;;=Generated by DICOMP from ^DIP0 during the sort/print option.
 ;;^DD(.401419,1,"DT")
 ;;=2930201
 ;;^DD(.401419,2,0)
 ;;=OVERFLOW CODE^K^^OVF0;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.401419,2,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.401419,2,9)
 ;;=@
 ;;^DD(.401419,2,21,0)
 ;;=^^3^3^2930201^
 ;;^DD(.401419,2,21,1,0)
 ;;=This is MUMPS code generated when needed by DICOMP, when sorting by a
 ;;^DD(.401419,2,21,2,0)
 ;;=field that must be gotten to relationally, or a computed field.  This
 ;;^DD(.401419,2,21,3,0)
 ;;=will only be used if DICOMP generates overflow code in the X array.
 ;;^DD(.401419,2,23,0)
 ;;=^^1^1^2930201^
 ;;^DD(.401419,2,23,1,0)
 ;;=Generated by DICOMP from ^DIP0 during the sort/print option.
 ;;^DD(.401419,2,"DT")
 ;;=2930201

DINIT13
DINIT13 ;SFISC/-INITIALIZE VA FILEMAN ;5/23/96  11:20
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT14:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;.401,8,0 TEMPLATE TYPE^S^1:ARCHIVING SEARCH;^0;8^Q
 ;;.401,8,3 Enter a 1 if this is an ARCHIVING SEARCH template (i.e., used to store lists of records to be archived) as opposed to a normal SEARCH or SORT template
 ;;.401,10,0 DESCRIPTION^.4012^^%D;0
 ;;.402,10,0 DESCRIPTION^.4021^^%D;0
 ;;.4012,0,"UP" .401
 ;;.4021,0,"UP" .402
 ;;.4,8,0 TEMPLATE TYPE^S^1:FILEGRAM;2:EXTRACT;3:EXPORT;7:SELECTED EXPORT FIELDS;^0;8^Q
 ;;.4,8,1,0 ^.1^^-1
 ;;.4,8,1,1,0 .4^FG^MUMPS
 ;;.4,8,1,1,1 S %=$S(X=1:"""FG""",1:"") I %]"" S A1=$P(@(DIC_"DA,0)"),U,1),@(DIC_%_",A1,DA)=""""") K %,A1
 ;;.4,8,1,1,2 S %=$S(X=1:"""FG""",1:"") I %]"" S A1=$P(@(DIC_"DA,0)"),U,1) K @(DIC_%_",A1,DA)"),%,A1
 ;;.4,8,1,1,"%D",0 ^^1^1^2921002^^^^
 ;;.4,8,1,1,"%D",0,"LE" 1
 ;;.4,8,1,1,"%D",1,0 Used to do a quick lookup of FILEGRAM type of print templates.
 ;;.4,8,1,1,"DT" 2901106
 ;;.4,8,3 Enter a 1 if this is a FILEGRAM template, 2 if this is an EXTRACT template, 3 if an EXPORT template, 7 if a SELECTED FIELDS template, as opposed to a normal PRINT template.
 ;;.4,8,"DT" 2921110
 ;;.4,20,0 DESTINATION FILE^NJ16,6^^0;9^K:+X'=X!(X>999999999)!(X<2)!(X?.E1"."7N.N) X
 ;;.4,20,3 Type a Number between 2 and 999999999, 6 Decimal Digits
 ;;.4,20,21,0 ^^2^2^2921002^
 ;;.4,20,21,1,0 This field holds the number of the file that is designed to receive
 ;;.4,20,21,2,0 data from other files by using the Extract Tool.
 ;;.4,20,"DT" 2920923
 ;;.4,50,0 FILEGRAM/EXTR FILE^.41A^^1;0
 ;;.4,50,"DT" 2920514
 ;;.4,100,0 EXPORT FIELD^.42A^^100;0
 ;;.4,100,21,0 ^^1^1^2921123^^
 ;;.4,100,21,1,0 This multiple holds information about each field being exported.
 ;;.4,105,0 EXPORT FORMAT^P.44'^DIST(.44,^105;1^Q
 ;;.4,105,21,0 ^^1^1^2921123^
 ;;.4,105,21,1,0 This field contains the foreign format used to make the export template.
 ;;.4,105,"DT" 2920904
 ;;.4,110,0 EXPORT TEMPLATE CREATED?^S^1:YES;0:NO;^105;3^Q
 ;;.4,110,21,0 ^^2^2^2921119^
 ;;.4,110,21,1,0 If YES, this Selected Fields for Export template has been used to create
 ;;.4,110,21,2,0 an Export template.
 ;;.4,110,"DT" 2920904
 ;;.4,115,0 MULTIPLE PATH^F^^105;4^K:$L(X)>30!($L(X)<1) X
 ;;.4,115,3 Answer must be 1-30 characters in length.
 ;;.4,115,21,0 ^^2^2^2921119^
 ;;.4,115,21,1,0 This field holds a list of field numbers representing the deepest multiple
 ;;.4,115,21,2,0 contained in this Export template.
 ;;.4,115,"DT" 2921119
 ;;.4,704,0 HEADER^CJ60^^ ; ^S X=$S($D(^DIPT(D0,"H")):^("H"),1:"")
 ;;.4,707,0 SUB-HEADER SUPPRESSED^S^1:YES^SUB;1^Q
 ;;.4,1620,0 PRINT FIELDS^XCmJ50^^ ; ^D ^DIPT
 ;;.401,15,0 SEARCH SPECIFICATIONS^.4011^^O;0
 ;;.4011,0 FIELD^.01^1
 ;;.4011,0,"NM","FIELD"
 ;;.4011,.01,0 SEARCH SPECIFICATIONS^WL^^0;1
 ;;.4011,0,"UP" .401
 ;;.401,1620,0 SORT FIELDS^CmJ50^^ ; ^D DIBT^DIPT
 ;;.401,491620,0 PRINT TEMPLATE^F^^DIPT;1^K:'$D(^DIPT("B",X)) X
 ;;.401,491620,4 N D1 S D1(1)="If this Sort Template should always be used with a particular",D1(2)="Print Template, enter the name of that Print Template.",D1(3)="" D EN^DDIOL(.D1)

DINIT14
DINIT14 ;SFISC/YJK-INITIALIZE VA FILEMAN ;9/9/94  13:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT2 S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(.6,0)
 ;;=DD AUDIT^.6
 ;;^DIC(.6,0,"GL")
 ;;=^DDA(
 ;;^DIC("B","DD AUDIT",.6)
 ;;=
 ;;^DIC(.6,"%D",0)
 ;;=^^1^1^2940908^
 ;;^DIC(.6,"%D",1,0)
 ;;=This file stores an audit trail of changes made to data dictionaries.
 ;;^DD(.6,0)
 ;;=FIELD^^.07^12
 ;;^DD(.6,0,"ID",.03)
 ;;=W "   ",$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_$E($P(^(0),U,3),2,3)
 ;;^DD(.6,0,"ID",.04)
 ;;=S %I=Y,Y=$S('$D(^(0)):"",$D(^VA(200,+$P(^(0),U,4),0))#2:$P(^(0),U,1),1:""),C=$P($G(^DD(200,.01,0)),U,2) D:C]"" Y^DIQ:Y]"" W "   ",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I
 ;;^DD(.6,0,"NM","DD AUDIT")
 ;;=
 ;;^DD(.6,.001,0)
 ;;=NUMBER^NJ7,0^^ ^K:+X'=X!(X>9999999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.6,.001,3)
 ;;=A whole number greater than 1.
 ;;^DD(.6,.01,0)
 ;;=FIELD NUMBER^RF^^0;1^K:$L(X)>10!($L(X)<1)!'(X'?1P.E) X
 ;;^DD(.6,.01,1,0)
 ;;=^.1
 ;;^DD(.6,.01,1,1,0)
 ;;=.6^B
 ;;^DD(.6,.01,1,1,1)
 ;;=S ^DDA(DDA,"B",$E(X,1,30),DA)=""
 ;;^DD(.6,.01,1,1,2)
 ;;=K ^DDA(DDA,"B",$E(X,1,30),DA)
 ;;^DD(.6,.01,3)
 ;;=Answer must be 1-10 characters in length.
 ;;^DD(.6,.02,0)
 ;;=TYPE^RS^E:EDIT;N:NEW;D:DELETE;^0;2^Q
 ;;^DD(.6,.03,0)
 ;;=DATE UPDATED^RD^^0;3^S %DT="ETR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(.6,.03,1,0)
 ;;=^.1
 ;;^DD(.6,.03,1,1,0)
 ;;=.6^D
 ;;^DD(.6,.03,1,1,1)
 ;;=S ^DDA(DDA,"D",$E(X,1,30),DA)=""
 ;;^DD(.6,.03,1,1,2)
 ;;=K ^DDA(DDA,"D",$E(X,1,30),DA)
 ;;^DD(.6,.04,0)
 ;;=USER^RP200'^VA(200,^0;4^Q
 ;;^DD(.6,.04,1,0)
 ;;=^.1
 ;;^DD(.6,.04,1,1,0)
 ;;=.6^E
 ;;^DD(.6,.04,1,1,1)
 ;;=S ^DDA(DDA,"E",$E(X,1,30),DA)=""
 ;;^DD(.6,.04,1,1,2)
 ;;=K ^DDA(DDA,"E",$E(X,1,30),DA)
 ;;^DD(.6,.05,0)
 ;;=ATTRIBUTE NAME^F^^0;5^K:$L(X)>75!($L(X)<1) X
 ;;^DD(.6,.05,3)
 ;;=Answer must be 1-75 characters in length.
 ;;^DD(.6,.06,0)
 ;;=ATTRIBUTE NUMBER^F^^0;6^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.6,.06,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.6,.07,0)
 ;;=FILE NUMBER^F^^0;7^K:$L(X)>15!($L(X)<1) X
 ;;^DD(.6,.07,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(.6,1,0)
 ;;=OLD VALUE^F^^1;E1,245^K:$L(X)>245!($L(X)<1) X
 ;;^DD(.6,1.1,0)
 ;;=OLD VALUE(S)^.601^^1.1;0
 ;;^DD(.6,2,0)
 ;;=NEW VALUE^F^^2;E1,245^K:$L(X)>245!($L(X)<1) X
 ;;^DD(.6,2.1,0)
 ;;=NEW VALUE(S)^.602^^2.1;0
 ;;^DD(.601,0)
 ;;=OLD VALUE(S) SUB-FIELD^^.01^1
 ;;^DD(.601,0,"NM","OLD VALUE(S)")
 ;;=
 ;;^DD(.601,0,"UP")
 ;;=.6
 ;;^DD(.601,.01,0)
 ;;=OLD VALUE(S)^WL^^0;1^Q
 ;;^DD(.602,0)
 ;;=NEW VALUE(S) SUB-FIELD^^.01^1
 ;;^DD(.602,0,"NM","NEW VALUE(S)")
 ;;=
 ;;^DD(.602,0,"UP")
 ;;=.6
 ;;^DD(.602,.01,0)
 ;;=NEW VALUE(S)^WL^^0;1^Q

DINIT2
DINIT2 ;SFISC/GFT-INITIALIZE VA FILEMAN ;7/22/94  10:41
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT20:X?.P S @("^DD("_$E($P(X," ",2),3,99)_")=Y")
 ;;.2,0 DESTINATION^
 ;;.2,0,"NM","DESTINATION"
 ;;.2,.01,0 DESTINATION^P^DIC(.2,^0;1^Q
 ;;.2,.01,3 WHERE THIS DATA GOES (TO WHAT FORM, SYSTEM, ETC.)
 ;;.21,0 DATA DESTINATION
 ;;.21,0,"NM","DATA-DESTINATION"
 ;;.21,.01,0 DATA DESTINATION^F^^0;1^K:$L(X)<2!($L(X)>80) X
 ;;.21,.01,1,0 ^.1^1^1
 ;;.21,.01,1,1,0 .21^B
 ;;.21,.01,1,1,1 S ^DIC(.2,"B",X,DA)=""
 ;;.21,.01,1,1,2 K ^DIC(.2,"B",X,DA)

DINIT20
DINIT20 ;SFISC/XAK-INITIALIZE VA FILEMAN ;07:33 AM  14 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT22:X?.P S @("^DD(1.1,"_$E($P(X," ",2),3,99)_")=Y")
 ;;0 FIELD^^.001,9
 ;;0,"ID","WRITE" N % S %=$P(^(0),U,2) D EN^DDIOL("   "_$E(%,4,5)_"-"_$E(%,6,7)_"-"_$E(%,2,3)_"@"_$E($P(%_"0000",".",2),1,4),"","?0")
 ;;0,"NM","AUDIT"
 ;;.001,0 NUMBER^NJ7,0^^ ^K:+X'=X!(X<1)!(X?.E1"."1N.N) X
 ;;.001,3 A whole number greater than 1.
 ;;.01,0 INTERNAL ENTRY NUMBER^RF^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>16!($L(X)<1)!'(X'?1P.E) X
 ;;.01,.1 The Internal Number of the Entry that has been audited.
 ;;.01,1,0 ^.1
 ;;.01,1,1,0 1.1^B
 ;;.01,1,1,1 S ^DIA(DIA,"B",$E(X,1,30),DA)=""
 ;;.01,1,1,2 K ^DIA(DIA,"B",$E(X,1,30),DA)
 ;;.02,0 DATE/TIME RECORDED^RD^^0;2^S %DT="ETXR" D ^%DT S X=Y K:Y<1 X
 ;;.02,1,0 ^.1
 ;;.02,1,1,0 1.1^C
 ;;.02,1,1,1 S ^DIA(DIA,"C",$E(X,1,30),DA)=""
 ;;.02,1,1,2 K ^DIA(DIA,"C",$E(X,1,30),DA)
 ;;.03,0 FIELD NUMBER^RF^^0;3^K:$L(X)>10!$L(X)<1) X
 ;;.03,3 The number of the field that was audited.
 ;;.04,0 USER^RP200'^VA(200,^0;4^Q
 ;;.04,1,0 ^.1
 ;;.04,1,1,0 1.1^D
 ;;.04,1,1,1 S ^DIA(DIA,"D",$E(X,1,30),DA)=""
 ;;.04,1,1,2 K ^DIA(DIA,"D",$E(X,1,30),DA)
 ;;1,0 ENTRY NAME^CJ30^^ ; ^S %=^DIC(DIA,0,"GL"),X=^DIA(DIA,D0,0),X=$S($D(@(%_+X_",0)")):$P(^(0),U,1),1:""),C=$S($D(^DD(DIA,.01,0)):$P(^(0),U,2),1:""),Y=X D:Y]"" Y^DIQ:C]"" S X=Y,C=","
 ;;1,9 ^
 ;;1.1,0 FIELD NAME^CJ50X^^ ; ^S Y(1.1,1.1)=$S($D(^DIA(DIA,D0,0)):$P(^(0),U,3),1:"") X ^DD(1.1,1.1,9.2) K Y(1.1) S X=$E(X,1,$L(X)-1)
 ;;1.1,9 ^
 ;;1.1,9.2 X ^DD(1.1,1.1,9.3) S X="" F %=1:1:%-1 S X=X_Y(1.1,%)_","
 ;;1.1,9.3 S X1=DIA F %=1:1 S X=$P(Y(1.1,1.1),",",%) Q:X=""  S Y(1.1,%)=$S($D(^DD(X1,X,0)):$P(^(0),U,1,2),1:"????"),X1=+$P(Y(1.1,%),U,2),Y(1.1,%)=$P(Y(1.1,%),U,1)
 ;;2,0 OLD VALUE^CJ80^^ ; ^S X=$S($D(^DIA(DIA,D0,2)):^(2),1:"<no previous value>")
 ;;2,9 ^
 ;;2.1,0 OLD INTERNAL VALUE^F^^2.1;1^K:$L(X)>30 X
 ;;2.2,0 DATATYPE OF OLD VALUE^S^S:SET;P:POINTER;V:VARIABLE POINTER;^2.1;2^Q
 ;;3,0 NEW VALUE^CJ80^^ ; ^S X=$S($D(^DIA(DIA,D0,3)):^(3),1:"<deleted>")
 ;;3,9 ^
 ;;3.1,0 NEW INTERNAL VALUE^F^^3.1;1^K:$L(X)>30 X
 ;;3.2,0 DATATYPE OF NEW VALUE^S^S:SET;P:POINTER;V:VARIABLE POINTER;^3.1;2^Q

DINIT21
DINIT21 ;SFISC/GFT-INITIALIZE VA FILEMAN ;9/8/94  11:15
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) Q:X?.P  S D="^DD(""OS"","_$E($P(X," ",2),3,99)_")" S @D=Y
 ;;0 MUMPS OPERATING SYSTEM^.7
 ;;8,0 MSM^^127^5000^^1^63
 ;;8,1 B X
 ;;8,"SDP" O @("DIO:"_DLP) F %=0:0 U DIO R % Q:$ZA=X&($ZB>Y)!($ZA>X)  U IO W:$A(%)'=12 ! W %
 ;;8,"SDPEND" S X=$ZA,Y=$ZB
 ;;8,"XY" U $I:(::::::IOY*256+IOX)
 ;;8,8 X ^DD("$O")
 ;;8,18 I $D(^ (X))
 ;;8,"ZS" ZR  X "S %Y=0 F  S %Y=$O(^UTILITY($J,0,%Y)) Q:%Y=""""  Q:'$D(^(%Y))  ZI ^(%Y)" ZS @X
 ;;9,0 DTM-PC^^127^5000^^1^115^4095
 ;;9,1 B X
 ;;9,8 D:$P($ZVER,"/",2)<4 ^%VARLOG X:$P($ZVER,"/",2)'<4 ^DD("$O")
 ;;9,18 I $ZRSTATUS(X)'=""
 ;;9,"SDP" O @("DIO:"_"(""R"":"_$P(DLP,":",2,9)) F %=0:0 U DIO R % Q:$ZIOS=3  U IO W:$A(%)'=12 ! W %
 ;;9,"SDPEND" Q
 ;;9,"XY" S $X=IOX,$Y=IOY
 ;;9,"ZS" S %X="" X "S %Y=0 F  S %Y=$O(^UTILITY($J,0,%Y)) Q:%Y=""""  Q:'$D(^(%Y))  S %X=%X_$C(10)_^(%Y)" ZS @X:$E(%X,2,999999)
 ;;16,0 DSM for OpenVMS^^108^5000^^1^63^255
 ;;16,1 U @("$I:"_$P("NO",1,'X)_"CENABLE")
 ;;16,8 D DOLRO^%ZOSV
 ;;16,18 I $D(^ (X))!$D(^!(X))
 ;;16,"SDP" O DIO U DIO:DISCONNECT F %=0:0 U DIO R % Q:%="#$#"  U IO W:$A(%)'=12 ! W %
 ;;16,"SDPEND" W !,"#$#",! C IO
 ;;16,"XY" U $I:(NOCURSOR,X=IOX,Y=IOY,CURSOR)
 ;;16,"ZS" ZR  X "S %Y=0 F  S %Y=$O(^UTILITY($J,0,%Y)) Q:%Y=""""  Q:'$D(^(%Y))  ZI ^(%Y)" ZS @X
 ;;17,0 GT.M(VAX)^^120^99999^^1^64
 ;;17,1 U @("$I:"_$P("NO",1,'X)_"CENABLE")
 ;;17,8 X ^DD("$O")
 ;;17,18 I $ZSEARCH(X_".M")'=""
 ;;17,"SDP" O DIO F  U DIO R % Q:%="#$#"  U IO W:$A(%)'=12 ! W %
 ;;17,"SDPEND" W !,"#$#",! C IO
 ;;17,"XY" S $X=IOX,$Y=IOY
 ;;17,"ZS" O X:NEWV S %Y="" F  S %Y=$O(^UTILITY($J,0,%Y)) C:%Y="" X Q:%Y=""  U X W ^(%Y),!
 ;;18,0 M/SQL^^120^8000^^1
 ;;18,1 B X
 ;;18,8 X ^DD("$O")
 ;;18,18 I $D(^ROUTINE(X))>1
 ;;18,"SDP" C DIO O DIO F %=0:0 U DIO R % Q:%="#$#"  U IO W %
 ;;18,"SDPEND" W !,"#$#",! C IO
 ;;18,"XY" S $Y=IOY,$X=IOX
 ;;18,"ZS" ZR  X "S %Y=0 F  S %Y=$O(^UTILITY($J,0,%Y)) Q:%Y=""""  Q:'$D(^(%Y))  ZI ^(%Y)" ZS @X
 ;;100,0 OTHER^^40^5000
 ;;100,1 Q

DINIT22
DINIT22 ;SFISC/DPC-LOAD DATA TYPE FILE DD ;9/9/94  13:22
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT220:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(.81,0,"GL")
 ;;=^DI(.81,
 ;;^DIC("B","DATA TYPE",.81)
 ;;=
 ;;^DIC(.81,"%D",0)
 ;;=^^2^2^2940908^
 ;;^DIC(.81,"%D",1,0)
 ;;=This file stores all of the data types that VA FileMan allows in the
 ;;^DIC(.81,"%D",2,0)
 ;;=MODIFY FILE ATTRIBUTES option.
 ;;^DD(.81,0)
 ;;=FIELD^^1^2
 ;;^DD(.81,0,"DDA")
 ;;=N
 ;;^DD(.81,0,"DT")
 ;;=2921009
 ;;^DD(.81,0,"IX","B",.81,.01)
 ;;=
 ;;^DD(.81,0,"IX","C",.81,1)
 ;;=
 ;;^DD(.81,0,"NM","DATA TYPE")
 ;;=
 ;;^DD(.81,0,"PT",.42,1)
 ;;=
 ;;^DD(.81,.01,0)
 ;;=NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X K X
 ;;^DD(.81,.01,1,0)
 ;;=^.1
 ;;^DD(.81,.01,1,1,0)
 ;;=.81^B
 ;;^DD(.81,.01,1,1,1)
 ;;=S ^DI(.81,"B",$E(X,1,30),DA)=""
 ;;^DD(.81,.01,1,1,2)
 ;;=K ^DI(.81,"B",$E(X,1,30),DA)
 ;;^DD(.81,.01,3)
 ;;=NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION
 ;;^DD(.81,.01,"DEL",1,0)
 ;;=I DA<100
 ;;^DD(.81,1,0)
 ;;=INTERNAL REPRESENTATION^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>1!($L(X)<1) X
 ;;^DD(.81,1,1,0)
 ;;=^.1
 ;;^DD(.81,1,1,1,0)
 ;;=.81^C
 ;;^DD(.81,1,1,1,1)
 ;;=S ^DI(.81,"C",$E(X,1,30),DA)=""
 ;;^DD(.81,1,1,1,2)
 ;;=K ^DI(.81,"C",$E(X,1,30),DA)
 ;;^DD(.81,1,1,1,"DT")
 ;;=2921009
 ;;^DD(.81,1,3)
 ;;=Answer must be 1 character in length.
 ;;^DD(.81,1,"DT")
 ;;=2921009

DINIT220
DINIT220 ;SFISC/DPC-LOAD DATA FOR DATA TYPE FILE ;7/22/94  10:50
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT24 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DI(.81,0)
 ;;=DATA TYPE^.81^99^10
 ;;^DI(.81,1,0)
 ;;=DATE/TIME^D
 ;;^DI(.81,2,0)
 ;;=NUMERIC^N
 ;;^DI(.81,3,0)
 ;;=SET OF CODES^S
 ;;^DI(.81,1,0)
 ;;=DATE/TIME^D
 ;;^DI(.81,2,0)
 ;;=NUMERIC^N
 ;;^DI(.81,3,0)
 ;;=SET OF CODES^S
 ;;^DI(.81,4,0)
 ;;=FREE TEXT^F
 ;;^DI(.81,5,0)
 ;;=WORD-PROCESSING^W
 ;;^DI(.81,6,0)
 ;;=COMPUTED^C
 ;;^DI(.81,7,0)
 ;;=POINTER TO A FILE^P
 ;;^DI(.81,8,0)
 ;;=VARIABLE-POINTER^V
 ;;^DI(.81,9,0)
 ;;=MUMPS^K
 ;;^DI(.81,99,0)
 ;;=RESERVED FOR FILEMAN

DINIT24
DINIT24 ;SFISC/GFT-INITIALIZE VA FILEMAN ;09:09 AM  15 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^DD(.5)
 ;BRING IN DD FOR FUNCTION FILE .5
 S ^DIC(.5,"%D",0)="^^4^4^2940908^"
 S ^DIC(.5,"%D",1,0)="This file stores information about FUNCTIONS used by FileMan.  The first"
 S ^DIC(.5,"%D",2,0)="100 records in this file are reserved for functions brought in during the"
 S ^DIC(.5,"%D",3,0)="FileMan INIT process.  The rest of the file is available for other"
 S ^DIC(.5,"%D",4,0)="developers to enter their own functions."
DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT25:X?.P S @("^DD(.5,"_$E($P(X," ",2),3,99)_")=Y")
 ;;0 ATTRIBUTE^
 ;;0,"NM","FUNCTION"
 ;;.01,0 NAME^RF^^0;1^K:$L(X)<2!($L(X)>30)!(X'?1U.ANP)!(X["$") X
 ;;.01,1,0 ^.1^1^1
 ;;.01,1,1,0 .5^B
 ;;.01,1,1,1 S @(DIC_"""B"",X,DA)=""""")
 ;;.01,1,1,2 K @(DIC_"""B"",X,DA)")
 ;;.01,3 Function Name must be 2-30 characters long, beginning with Alpha.
 ;;.01,"DEL",1,0 I DA<100
 ;;.02,0 MUMPS CODE^FR^^1;E1,255^D ^DIM I $D(X),'$D(DIQUIET),'$D(DDS) W "  ..OK"
 ;;.02,3 Enter MUMPS code that sets a value into 'X'.
 ;;.02,4 N D1 S D1(1)="For a 1-argument function, use 'X' as the argument.",D1(2)="For a 2-argument function, use 'X1' and 'X'.",D1(3)="Avoid FORs, IFs, and single-character scratch variables.",D1(4)="" D EN^DDIOL(.D1)
 ;;.02,9 @
 ;;1,0 EXPLANATION^F^^9;E1,245^K:$L(X)>245 X
 ;;2,0 DATE-VALUED^S^D:YES;X:NO;O:OPTIONAL (DEPENDS ON VALUE OF ARGUMENT);^2;1^Q
 ;;9,0 NUMBER OF ARGUMENTS^N^^3;1^K:X\1'=X!(X>8) X
 ;;10,0 WORD-PROCESSING^S^W:MEANINGFUL ONLY FOR W-P;^10;1
 ;;
OSDD ; BRING IN DD FOR MUMPS OS FILE .7 (CALLED FROM ^DINIT)
 F I=2:1 S X=$T(OSDD+I),Y=$P(X," ",3,99) Q:X?.P  S @("^DD(.7,"_$E($P(X," ",2),3,99)_")=Y")
 ;;0 FIELD^
 ;;.01,0 NAME^F^^0;1^Q
 ;;.01,1,0 ^.1^1^1
 ;;.01,1,1,0 .7^B
 ;;.01,1,1,1 S ^DD("OS","B",X,DA)=""
 ;;.01,1,1,2 K ^DD("OS","B",X,DA)
 ;;.01,21,0 ^^1^1^2940909^^
 ;;.01,21,1,0 Name of a MUMPS operating system that is supported by VA FileMan.
 ;;1,0 BREAK LOGIC^RF^^1;E1,250^D ^DIM
 ;;1,9 @
 ;;1,21,0 ^^2^2^2940909^^
 ;;1,21,1,0 MUMPS code to enable terminal break, i.e., to allow the user to interrupt
 ;;1,21,2,0 processing with <CTRL-C>.
 ;;419,0 MINIMUM SAFE $S^N^^0;2^K:+X'=X X
 ;;419,21,0 ^^1^1^2940909^
 ;;419,21,1,0 The minimum value for $S that will allow routines to process successfully.
 ;;2,0 GLOBAL LENGTH (MAX)^RN^^0;3^K:+X'=X!(X<30) X
 ;;2,21,0 ^^1^1^2940909^^
 ;;2,21,1,0 Maximum allowable length of a global.
 ;;3,0 ROUTINE SIZE (MAX)^RN^^0;4^K:+X'=X!(X<2048) X
 ;;3,21,0 ^^1^1^2940909^
 ;;3,21,1,0 Maximum allowable size of a routine.
 ;;4,0 CLOSING PRINCIPAL DEVICE^S^1:ALLOWED;^0;5^Q
 ;;4,21,0 ^^1^1^2940909^
 ;;4,21,1,0 Is closing a job's principal device allowed?
 ;;5,0 NEW COMMAND^S^1:SUPPORTED;^0;6^Q
 ;;5,21,0 ^^1^1^2940909^
 ;;5,21,1,0 Is the NEW command supported?
 ;;7,0 INDIVIDUAL SUBSCRIPT LENGTH^N^^0;7^K:X\1'=X!(X<9) X
 ;;7,21,0 ^^1^1^2940909^
 ;;7,21,1,0 Maximum length of an individual subscript.
 ;;8,0 SAVE SYMBOL TABLE^F^^8;E1,250^D ^DIM
 ;;8,9 @
 ;;8,21,0 ^^1^1^2940909^
 ;;8,21,1,0 MUMPS code that saves the contents of the local symbol table.
 ;;1820,0 ROUTINE EXISTENCE TEST^F^^18;E1,250^D ^DIM
 ;;1820,9 @
 ;;1820,21,0 ^^1^1^2940909^
 ;;1820,21,1,0 MUMPS code that tests for the existence of a routine.
 ;;2425,0 SET $X & $Y FROM 'IOX' & 'IOY'^F^^XY;E1,250^D ^DIM
 ;;2425,9 @
 ;;2425,21,0 ^^2^2^2940909^^
 ;;2425,21,1,0 MUMPS code to XECUTE to move the position of the cursor to the position
 ;;2425,21,2,0 specified by the variables IOX and IOY.
 ;;190416,0 WRITE FROM SDP^F^^SDP;E1,250^D ^DIM
 ;;190416,9 @
 ;;190416,21,0 ^^4^4^2940909^
 ;;190416,21,1,0 MUMPS code that READs data from SDP and WRITEs it to a device.  The $I
 ;;190416,21,2,0 value of the SDP device should be in variable DIO and the $I value
 ;;190416,21,3,0 for the output device in IO.  The DLP variable should contain the open
 ;;190416,21,4,0 parameters of the SDP device.
 ;;190416.1,0 FIND SDP END^F^^SDPEND;E1,250^D ^DIM
 ;;190416.1,9 @
 ;;190416.1,21,0 ^^1^1^2940909^
 ;;190416.1,21,1,0 MUMPS code that tests for the end of SDP.
 ;;2619,0 ZSAVE CODE^F^^ZS;E1,250^D ^DIM
 ;;2619,9 @
 ;;2619,21,0 ^^4^4^2940909^
 ;;2619,21,1,0 MUMPS code that will save a routine to disk.  The name of the routine
 ;;2619,21,2,0 must be in variable X.  The source code of the routine should be stored
 ;;2619,21,3,0 in ^UTLITY($J,0,%Y).  Each node of the array will become a line of the
 ;;2619,21,4,0 routine.

DINIT25
DINIT25 ;SFISC/XAK-INITIALIZE VA FILEMAN ;3/16/94  11:26 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT250:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DD(.41,0)
 ;;=FILEGRAM/EXTR FILE SUB-FIELD^^13^13
 ;;^DD(.41,0,"NM","FILEGRAM/EXTR FILE")
 ;;=
 ;;^DD(.41,0,"UP")
 ;;=.4
 ;;^DD(.41,.001,0)
 ;;=ORDER^NJ4,0^^ ^K:+X'=X!(X>9999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.41,.001,3)
 ;;=Type a Number between 1 and 9999, 0 Decimal Digits
 ;;^DD(.41,.01,0)
 ;;=FILEGRAM/EXTR FILE^NJ16,4^^0;1^K:+X'=X!(X>99999999999)!(X<2)!(X?.E1"."5N.N) X
 ;;^DD(.41,.01,1,0)
 ;;=^.1
 ;;^DD(.41,.01,1,1,0)
 ;;=.41^B
 ;;^DD(.41,.01,1,1,1)
 ;;=S ^DIPT(DA(1),1,"B",$E(X,1,30),DA)=""
 ;;^DD(.41,.01,1,1,2)
 ;;=K ^DIPT(DA(1),1,"B",$E(X,1,30),DA)
 ;;^DD(.41,.01,3)
 ;;=Type a Number between 2 and 99999999999, 4 Decimal Digits
 ;;^DD(.41,.02,0)
 ;;=LEVEL^RNJ2,0^^0;2^K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.41,.02,3)
 ;;=Type a Number between 1 and 99, 0 Decimal Digits
 ;;^DD(.41,.03,0)
 ;;=PARENT^NJ14,4^^0;3^K:+X'=X!(X>999999999)!(X<2)!(X?.E1"."5N.N) X
 ;;^DD(.41,.03,3)
 ;;=Type a Number between 2 and 999999999, 4 Decimal Digits
 ;;^DD(.41,.04,0)
 ;;=LINK TYPE^S^1:DINUM;2:DIRECT POINTER;3:MULTIPLE;4:BACKPOINTER^0;4^Q
 ;;^DD(.41,.05,0)
 ;;=USER RESPONSE TO GET HERE^F^^0;5^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.41,.05,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.41,.06,0)
 ;;=DATE LAST STORED^D^^0;6^S %DT="EX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(.41,.07,0)
 ;;=CROSS-REFERENCE^F^^0;7^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.41,.07,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.41,.07,21,0)
 ;;=^^1^1^2900405^
 ;;^DD(.41,.07,21,1,0)
 ;;=This field holds the X-ref to use in a backpointer.
 ;;^DD(.41,.08,0)
 ;;=ALL FIELDS IN FILE^S^1:YES;^0;8^Q
 ;;^DD(.41,10,0)
 ;;=FIELD NUMBER^.411A^^F;0
 ;;^DD(.41,11,0)
 ;;=DESTINATION FILE^NJ16,6^^0;9^K:+X'=X!(X>999999999)!(X<2)!(X?.E1"."7N.N) X
 ;;^DD(.41,11,3)
 ;;=Type a Number between 2 and 999999999, 6 Decimal Digits
 ;;^DD(.41,11,21,0)
 ;;=^^1^1^2921002^
 ;;^DD(.41,11,21,1,0)
 ;;=This field holds the number of the destination file or the destination subfile.
 ;;^DD(.41,12,0)
 ;;=DESTINATION FILE PARENT^NJ16,6^^0;10^K:+X'=X!(X>999999999)!(X<2)!(X?.E1"."7N.N) X
 ;;^DD(.41,12,3)
 ;;=Type a Number between 2 and 999999999, 6 Decimal Digits
 ;;^DD(.41,12,21,0)
 ;;=^^2^2^2921002^
 ;;^DD(.41,12,21,1,0)
 ;;=This field holds the number of the parent file or subfile of the
 ;;^DD(.41,12,21,2,0)
 ;;=DESTINATION FILE.
 ;;^DD(.41,13,0)
 ;;=DESTINATION FILE LOCATION^F^^0;11^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.41,13,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.41,13,21,0)
 ;;=^^1^1^2921002^
 ;;^DD(.41,13,21,1,0)
 ;;=This field holds the node and piece location of the DESTINATION FILE.
 ;;^DD(.411,0)
 ;;=FIELD NUMBER SUB-FIELD^^4^5
 ;;^DD(.411,0,"NM","FIELD NUMBER")
 ;;=
 ;;^DD(.411,0,"UP")
 ;;=.41
 ;;^DD(.411,.001,0)
 ;;=FIELD ORDER^NJ8,0^^ ^K:+X'=X!(X>99999999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.411,.001,3)
 ;;=Type a Number between 1 and 99999999, 0 Decimal Digits
 ;;^DD(.411,.01,0)
 ;;=FIELD NUMBER^NJ14,4^^0;1^K:+X'=X!(X>999999999)!(X<.001)!(X?.E1"."5N.N) X
 ;;^DD(.411,.01,1,0)
 ;;=^.1^^0
 ;;^DD(.411,.01,3)
 ;;=Type a Number between .001 and 999999999, 4 Decimal Digits
 ;;^DD(.411,1,0)
 ;;=CAPTION^CJ30^^ ; ^S %=+^DIPT(D0,1,D1,0),X=$S('%:"",$D(^DD(%,+^DIPT(D0,1,D1,"F",D2,0),0)):$P(^(0),U),1:"")
 ;;^DD(.411,1,9)
 ;;=^
 ;;^DD(.411,1,9.01)
 ;;=
 ;;^DD(.411,1,9.1)
 ;;=S %=+^DIPT(D0,1,D1,0),X=$S('%:"",$D(^DD(%,+^DIPT(D0,1,D1,"F",D2,0),0)):$P(^(0),U),1:"")
 ;;^DD(.411,3,0)
 ;;=DESTINATION FIELD NUMBER^NJ14,4^^0;3^K:+X'=X!(X>999999999)!(X<.001)!(X?.E1"."5N.N) X
 ;;^DD(.411,3,3)
 ;;=Type a Number between .001 and 999999999, 4 Decimal Digits
 ;;^DD(.411,3,21,0)
 ;;=^^2^2^2921002^
 ;;^DD(.411,3,21,1,0)
 ;;=This field holds the number of the field in the destination file
 ;;^DD(.411,3,21,2,0)
 ;;=that will contain the extracted data from FIELD NUMBER in the source file.
 ;;^DD(.411,4,0)
 ;;=DESTINATION FIELD LOCATION^F^^0;4^K:$L(X)>30!($L(X)<3) X
 ;;^DD(.411,4,3)
 ;;=Answer must be 3-30 characters in length.
 ;;^DD(.411,4,21,0)
 ;;=^^3^3^2921002^
 ;;^DD(.411,4,21,1,0)
 ;;=This field holds the node and piece location of the DESTINATION FIELD
 ;;^DD(.411,4,21,2,0)
 ;;=NUMBER. This is used at the time extract data is moved to the destination
 ;;^DD(.411,4,21,3,0)
 ;;=file.
 ;;^DD(.411,5,0)
 ;;= EXTERNAL FORMAT^S^1:MOVE EXTERNAL FORMAT TO DESTINATION FILE;^0;5^Q
 ;;^DD(.411,5,3)
 ;;=Enter 1 if external format of data should be moved to destination file.
 ;;^DD(.411,5,21,0)
 ;;=^^3^3^2921208^
 ;;^DD(.411,5,21,1,0)
 ;;=This code is used to determine if the external form of the data in the
 ;;^DD(.411,5,21,2,0)
 ;;=source file should be moved to the destination file.  If null, the
 ;;^DD(.411,5,21,3,0)
 ;;=internal format of the data is moved.

DINIT250
DINIT250 ;SFISC/DPC-LOAD PRINT TEMPLATE FILE DD (CONT) ;10/14/94  14:56
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT255:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DD(.42,0)
 ;;=EXPORT FIELD SUB-FIELD^^3^4
 ;;^DD(.42,0,"DT")
 ;;=2921013
 ;;^DD(.42,0,"IX","B",.42,.01)
 ;;=
 ;;^DD(.42,0,"NM","EXPORT FIELD")
 ;;=
 ;;^DD(.42,0,"UP")
 ;;=.4
 ;;^DD(.42,.01,0)
 ;;=FIELD ORDER^RNJ2,0^^0;1^K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.42,.01,1,0)
 ;;=^.1
 ;;^DD(.42,.01,1,1,0)
 ;;=.42^B
 ;;^DD(.42,.01,1,1,1)
 ;;=S ^DIPT(DA(1),100,"B",$E(X,1,30),DA)=""
 ;;^DD(.42,.01,1,1,2)
 ;;=K ^DIPT(DA(1),100,"B",$E(X,1,30),DA)
 ;;^DD(.42,.01,3)
 ;;=Type a Number between 1 and 99, 0 Decimal Digits
 ;;^DD(.42,.01,21,0)
 ;;=^^3^3^2941014^^
 ;;^DD(.42,.01,21,1,0)
 ;;=The integer in this field represents the order in which fields are
 ;;^DD(.42,.01,21,2,0)
 ;;=exported.  The field order numbers are not always consecutive,
 ;;^DD(.42,.01,21,3,0)
 ;;=but they do represent the sequence in which fields are sent.
 ;;^DD(.42,.01,"DT")
 ;;=2920903
 ;;^DD(.42,1,0)
 ;;=DATA TYPE^*P.81'^DI(.81,^0;2^S DIC("S")="N %IR S %IR=$P($G(^(0)),U,2) I (%IR=""D"")!(%IR=""N"")!(%IR=""F"")" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
 ;;^DD(.42,1,3)
 ;;=
 ;;^DD(.42,1,12)
 ;;=Only data types of free text, date, and numeric are recognized for exported fields.
 ;;^DD(.42,1,12.1)
 ;;=S DIC("S")="N %IR S %IR=$P($G(^(0)),U,2) I (%IR=""D"")!(%IR=""N"")!(%IR=""F"")"
 ;;^DD(.42,1,21,0)
 ;;=^^3^3^2921119^
 ;;^DD(.42,1,21,1,0)
 ;;=The data type of the field as derived by the export tool or as input by the
 ;;^DD(.42,1,21,2,0)
 ;;=user is held in this field.  This data type may not correspond to the data
 ;;^DD(.42,1,21,3,0)
 ;;=type found in the data dictionary.
 ;;^DD(.42,1,"DT")
 ;;=2921013
 ;;^DD(.42,2,0)
 ;;=LENGTH FOR OUTPUT^NJ5,0^^0;3^K:+X'=X!(X>10000)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.42,2,3)
 ;;=Type a Number between 1 and 10000, 0 Decimal Digits
 ;;^DD(.42,2,21,0)
 ;;=^^2^2^2921119^
 ;;^DD(.42,2,21,1,0)
 ;;=The number of characters allotted to the field for fixed length export is
 ;;^DD(.42,2,21,2,0)
 ;;=stored here.
 ;;^DD(.42,2,"DT")
 ;;=2920903
 ;;^DD(.42,3,0)
 ;;=NAME OF FOREIGN FIELD^F^^0;4^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.42,3,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.42,3,21,0)
 ;;=^^2^2^2921119^
 ;;^DD(.42,3,21,1,0)
 ;;=The name of the field as it is known in the importing application is
 ;;^DD(.42,3,21,2,0)
 ;;=stored here.  The user supplies this information.
 ;;^DD(.42,3,"DT")
 ;;=2921123

DINIT255
DINIT255 ;SFISC/MLH-FILEGRAM ERROR LOG ;9/9/94  14:26
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT26:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC(1.13,"%D",0)
 ;;=^^2^2^2930712^
 ;;^DIC(1.13,"%D",1,0)
 ;;=This file stores information about Filegram errors and the text
 ;;^DIC(1.13,"%D",2,0)
 ;;=of the affected Filegrams.
 ;;^DD(1.13,0,"IX","B",1.13,.01)
 ;;=
 ;;^DIC("B","FILEGRAM ERROR LOG",1.13)
 ;;=
 ;;^DD(1.13,0)
 ;;=FIELD^^2100^4
 ;;^DD(1.13,0,"DDA")
 ;;=N
 ;;^DD(1.13,0,"DT")
 ;;=2900904
 ;;^DD(1.13,0,"NM","FILEGRAM ERROR LOG")
 ;;=
 ;;^DD(1.13,.001,0)
 ;;=FILEGRAM NUMBER^NJ6,0^^ ^K:+X'=X!(X>999999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(1.13,.001,3)
 ;;=Type a Number between 1 and 999999, 0 Decimal Digits
 ;;^DD(1.13,.001,23,0)
 ;;=^^1^1^2900904^
 ;;^DD(1.13,.001,23,1,0)
 ;;=Filegram number
 ;;^DD(1.13,.001,"DT")
 ;;=2900904
 ;;^DD(1.13,.01,0)
 ;;=LINE OF ERROR^RNJ5,0^^0;1^K:+X'=X!(X>99999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(1.13,.01,1,0)
 ;;=^.1
 ;;^DD(1.13,.01,1,1,0)
 ;;=1.13^B
 ;;^DD(1.13,.01,1,1,1)
 ;;=S ^DIAR(1.13,"B",$E(X,1,30),DA)=""
 ;;^DD(1.13,.01,1,1,2)
 ;;=K ^DIAR(1.13,"B",$E(X,1,30),DA)
 ;;^DD(1.13,.01,3)
 ;;=Type a Number between 1 and 99999, 0 Decimal Digits
 ;;^DD(1.13,.01,23,0)
 ;;=^^2^2^2900904^
 ;;^DD(1.13,.01,23,1,0)
 ;;=Line number returned in second piece of DIFGER indicating filegram line
 ;;^DD(1.13,.01,23,2,0)
 ;;=where error occurred
 ;;^DD(1.13,.01,"DT")
 ;;=2900904
 ;;^DD(1.13,.02,0)
 ;;=ERROR CODE^NJ2,0^^0;2^K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(1.13,.02,3)
 ;;=Type a Number between 1 and 99, 0 Decimal Digits
 ;;^DD(1.13,.02,23,0)
 ;;=^^2^2^2900904^
 ;;^DD(1.13,.02,23,1,0)
 ;;=Error code returned in first piece of DIFGER indicating type of
 ;;^DD(1.13,.02,23,2,0)
 ;;=installation error
 ;;^DD(1.13,.02,"DT")
 ;;=2900904
 ;;^DD(1.13,2100,0)
 ;;=FILEGRAM^1.1321^^21;0
 ;;^DD(1.13,2100,23,0)
 ;;=^^1^1^2900904^
 ;;^DD(1.13,2100,23,1,0)
 ;;=Text of the filegram
 ;;^DD(1.1321,0)
 ;;=FILEGRAM SUB-FIELD^^.01^1
 ;;^DD(1.1321,0,"DT")
 ;;=2900904
 ;;^DD(1.1321,0,"NM","FILEGRAM")
 ;;=
 ;;^DD(1.1321,0,"UP")
 ;;=1.13
 ;;^DD(1.1321,.01,0)
 ;;=FILEGRAM^WL^^0;1^Q
 ;;^DD(1.1321,.01,"DT")
 ;;=2900904

DINIT26
DINIT26 ;SFISC/XAK-INITIALIZE VA FILEMAN ;9/9/94  14:16
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT260:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(1.11,0,"GL")
 ;;=^DIAR(1.11,
 ;;^DIC("B","ARCHIVAL ACTIVITY",1.11)
 ;;=
 ;;^DIC(1.11,"%D",0)
 ;;=^^1^1^2930712^
 ;;^DIC(1.11,"%D",1,0)
 ;;=This file stores information and status of data archiving activities.
 ;;^DD(1.11,0)
 ;;=FIELD^^16^23
 ;;^DD(1.11,0,"DT")
 ;;=2920514
 ;;^DD(1.11,0,"ID",1)
 ;;=W "   ",$O(^DD(+$P(^(0),U,2),0,"NM",0)),$E(^DIAR(1.11,Y,0),0)
 ;;^DD(1.11,0,"ID",4)
 ;;=W ?40,$E($P(^(0),U,5),4,5)_"-"_$E($P(^(0),U,5),6,7)_"-"_$E($P(^(0),U,5),2,3)
 ;;^DD(1.11,0,"ID",7)
 ;;=W "   ",$P($P($C(59)_$S($D(^DD(1.11,7,0)):$P(^(0),U,3),1:0),$C(59)_$P(^DIAR(1.11,Y,0),U,8)_":",2),$C(59),1)
 ;;^DD(1.11,0,"ID",8)
 ;;=S %I=Y,Y=$S('$D(^(0)):"",$D(^VA(200,+$P(^(0),U,9),0))#2:$P(^(0),U,1),1:""),C=$P($G(^DD(200,.01,0)),U,2) D:C]"" Y^DIQ:Y]"" W "   SELECTOR:",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I
 ;;^DD(1.11,0,"ID",16)
 ;;=W "   ",@("$P($P($C(59)_$S($D(^DD(1.11,16,0)):$P(^(0),U,3),1:0)_$E("_DIC_"Y,0),0),$C(59)_$P(^(0),U,17)_"":"",2),$C(59),1)")
 ;;^DD(1.11,0,"NM","ARCHIVAL ACTIVITY")
 ;;=
 ;;^DD(1.11,.01,0)
 ;;=ARCHIVE NUMBER^RNJ7,0^^0;1^K:+X'=X!(X>9999999)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(1.11,.01,1,0)
 ;;=^.1
 ;;^DD(1.11,.01,1,1,0)
 ;;=1.11^B
 ;;^DD(1.11,.01,1,1,1)
 ;;=S ^DIAR(1.11,"B",$E(X,1,30),DA)=""
 ;;^DD(1.11,.01,1,1,2)
 ;;=K ^DIAR(1.11,"B",$E(X,1,30),DA)
 ;;^DD(1.11,.01,3)
 ;;=Type a Number between 1 and 9999999, 0 Decimal Digits
 ;;^DD(1.11,1,0)
 ;;=FILE^RP1'^DIC(^0;2^Q
 ;;^DD(1.11,1,1,0)
 ;;=^.1
 ;;^DD(1.11,1,1,1,0)
 ;;=1.11^C
 ;;^DD(1.11,1,1,1,1)
 ;;=S ^DIAR(1.11,"C",$E(X,1,30),DA)=""
 ;;^DD(1.11,1,1,1,2)
 ;;=K ^DIAR(1.11,"C",$E(X,1,30),DA)
 ;;^DD(1.11,1,3)
 ;;=Enter the file that this archival activity will effect.
 ;;^DD(1.11,2,0)
 ;;=SEARCH TEMPLATE^RP.401^DIBT(^0;3^Q
 ;;^DD(1.11,2,3)
 ;;=Enter the name of the sort/search template that you wish to use.
 ;;^DD(1.11,3,0)
 ;;=PRINT TEMPLATE^R*P.4'X^DIPT(^0;4^S DIC("S")="I $P(^(0),U,8)="_$S($D(DIAX):2,1:1)_",$P(^(0),U,4)=$P(^DIAR(1.11,DA,0),U,2)",DIC(0)="QE",D="F"_+$P(^DIAR(1.11,DA,0),U,2) D IX^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
 ;;^DD(1.11,3,3)
 ;;=Enter the name of the FILEGRAM OR EXTRACT print template that you wish to use.
 ;;^DD(1.11,3,12)
 ;;=Select a print template in Filegram or Extract Format.
 ;;^DD(1.11,3,12.1)
 ;;=S DIC("S")="I $P(^(0),U,8)="_$S($D(DIAX):2,1:1)_",$P(^(0),U,4)=$P(^DIAR(1.11,DA,0),U,2)"
 ;;^DD(1.11,3,"DT")
 ;;=2920514
 ;;^DD(1.11,4,0)
 ;;=SELECT DATE^RD^^0;5^S %DT="ET" D ^%DT S X=Y K:Y<1 X
 ;;^DD(1.11,4,3)
 ;;=Enter the select date of this archival activity.
 ;;^DD(1.11,5,0)
 ;;=ARCHIVER^P200'^VA(200,^0;6^Q
 ;;^DD(1.11,5,3)
 ;;=Enter the name of the user that is doing the archiving.
 ;;^DD(1.11,6,0)
 ;;=NUMBER OF ITEMS TO ARCHIVE^RNJ7,0^^0;7^K:+X'=X!(X>9999999)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(1.11,6,3)
 ;;=Type a Number between 0 and 9999999, 0 Decimal Digits
 ;;^DD(1.11,7,0)
 ;;=ARCHIVAL STATUS^S^1:SELECTED;2:EDITED;4:ARCHIVED (TEMPORARY);5:ARCHIVED (PERMANENT);6:UPDATED DESTINATION FILE;90:PURGED;^0;8^Q
 ;;^DD(1.11,7,"DT")
 ;;=2920511
 ;;^DD(1.11,8,0)
 ;;=SELECTOR^P200'^VA(200,^0;9^Q
 ;;^DD(1.11,9,0)
 ;;=PURGER^P200'^VA(200,^0;10^Q
 ;;^DD(1.11,10,0)
 ;;=ARCHIVE DATE^D^^0;11^S %DT="E" D ^%DT S X=Y K:Y<1 X
 ;;^DD(1.11,11,0)
 ;;=PURGE DATE^D^^0;12^S %DT="E" D ^%DT S X=Y K:Y<1 X

DINIT260
DINIT260 ;SFISC/XAK-INITIALIZE VA FILEMAN ;12/14/92  2:48 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT27:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DD(1.11,12,0)
 ;;=DATE LAST PRINTED^D^^0;13^S %DT="ETX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(1.11,12,3)
 ;;=Enter the date that the listing of items to be archived was last printed.
 ;;^DD(1.11,13,0)
 ;;=ARCHIVING ACTION IN PROGRESS^S^1:SELECTION;2:EDITING;4:ARCHIVING (TEMPORARY);5:ARCHIVING (PERMANENT);6:UPDATING DESTINATION FILE;90:PURGING;99:CANCELLING;^0;14^Q
 ;;^DD(1.11,13,3)
 ;;=Entry will be made here by system when user begins performing some action to this ARCHIVAL ACTIVITY and will be deleted when action is complete, to lock out other users.
 ;;^DD(1.11,14,0)
 ;;=DATE/TIME ACTIVITY BEGAN^D^^0;15^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(1.11,14,3)
 ;;=Date/time user began archiving action currently in progress.
 ;;^DD(1.11,15,0)
 ;;=USER PERFORMING ACTION^P200'^VA(200,^0;16^Q
 ;;^DD(1.11,15,3)
 ;;=User that initiated the archiving action.
 ;;^DD(1.11,16,0)
 ;;=TYPE OF ARCHIVE^S^0:ARCHIVING;1:EXTRACT;^0;17^Q
 ;;^DD(1.11,16,21,0)
 ;;=^^4^4^2921002^
 ;;^DD(1.11,16,21,1,0)
 ;;=This field indicates the archiving type for this particular archival
 ;;^DD(1.11,16,21,2,0)
 ;;=activity entry.  This should be 0 if the archival process is being done
 ;;^DD(1.11,16,21,3,0)
 ;;=under the Archiving options; or should be 1 if the archival process is
 ;;^DD(1.11,16,21,4,0)
 ;;=being done under the Extract Tool options.
 ;;^DD(1.11,17,0)
 ;;=DESTINATION FILE^P1'^DIC(^0;18^Q
 ;;^DD(1.11,17,21,0)
 ;;=^^2^2^2921002^
 ;;^DD(1.11,17,21,1,0)
 ;;=This field holds the number of the destination file for this archival
 ;;^DD(1.11,17,21,2,0)
 ;;=activity.
 ;;^DD(1.11,18,0)
 ;;=ARCHIVE DEVICE LABEL^F^^0;19^K:$L(X)>45!($L(X)<2) X
 ;;^DD(1.11,18,3)
 ;;=Answer must be 2-45 characters in length.
 ;;^DD(1.11,18,21,0)
 ;;=^^2^2^2921002^
 ;;^DD(1.11,18,21,1,0)
 ;;=This field holds the label information that identifies your archival
 ;;^DD(1.11,18,21,2,0)
 ;;=medium.
 ;;^DD(1.11,30,0)
 ;;=SUBFILE NUMBER^F^^1;1^K:+X'=X X
 ;;^DD(1.11,30,3)
 ;;=Type the number of a sub-file data dictionary.
 ;;^DD(1.11,31,0)
 ;;=SUBFILE SUBSCRIPTS^F^^1;2^K:$L(X)>50!($L(X)<3) X
 ;;^DD(1.11,31,3)
 ;;=Answer must be 3-50 characters in length.
 ;;^DD(1.11,32,0)
 ;;=SUBFILE SCREEN^1.1132A^^S;0
 ;;^DD(1.11,100,0)
 ;;=DATA^1.113^^D;0
 ;;^DD(1.113,0)
 ;;=DATA SUB-FIELD^^.01^1
 ;;^DD(1.113,0,"NM","DATA")
 ;;=
 ;;^DD(1.113,0,"UP")
 ;;=1.11
 ;;^DD(1.113,.01,0)
 ;;=DATA^WL^^0;1^Q
 ;;^DD(1.1132,0)
 ;;=SUBFILE SCREEN SUB-FIELD^^1^2
 ;;^DD(1.1132,0,"NM","SUBFILE SCREEN")
 ;;=
 ;;^DD(1.1132,0,"UP")
 ;;=1.11
 ;;^DD(1.1132,.01,0)
 ;;=SUBSCRIPT^F^^0;1^K:$L(X)>10!($L(X)<1) X
 ;;^DD(1.1132,.01,3)
 ;;=Answer must be 1-10 characters in length.
 ;;^DD(1.1132,1,0)
 ;;=CODE^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(1.1132,1,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(1.1132,1,9)
 ;;=@
 ;;^DD(1.11,200,0)
 ;;=DESTINATION FILE ENTRIES^1.14^^EX;0
 ;;^DD(1.14,0)
 ;;=DESTINATION FILE ENTRIES SUB-FIELD^^.01^1
 ;;^DD(1.14,0,"NM","DESTINATION FILE ENTRIES")
 ;;=
 ;;^DD(1.14,0,"UP")
 ;;=1.11
 ;;^DD(1.14,.01,0)
 ;;=DESTINATION FILE ENTRIES^MNJ9,0X^^0;1^K:+X'=X!(X>999999999)!(X<0)!(X?.E1"."1N.N) X I $D(X) S DINUM=X
 ;;^DD(1.14,.01,1,0)
 ;;=^.1
 ;;^DD(1.14,.01,1,1,0)
 ;;=1.14^B
 ;;^DD(1.14,.01,1,1,1)
 ;;=S ^DIAR(1.11,DA(1),"EX","B",$E(X,1,30),DA)=""
 ;;^DD(1.14,.01,1,1,2)
 ;;=K ^DIAR(1.11,DA(1),"EX","B",$E(X,1,30),DA)
 ;;^DD(1.14,.01,3)
 ;;=Type a Number between 0 and 999999999, 0 Decimal Digits
 ;;^DD(1.14,.01,21,0)
 ;;=^^2^2^2921208^
 ;;^DD(1.14,.01,21,1,0)
 ;;=This field holds the internal entry number of the record created in the
 ;;^DD(1.14,.01,21,3,0)
 ;;=destination file.

DINIT27
DINIT27 ;SFISC/DPC-LOADS DD OF FOREIGN FORMAT FILE ;01:40 PM  13 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT270:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(.44,0,"GL")
 ;;=^DIST(.44,
 ;;^DIC("B","FOREIGN FORMAT",.44)
 ;;=
 ;;^DD(.44,0)
 ;;=FIELD^^11^19
 ;;^DD(.44,0,"DDA")
 ;;=N
 ;;^DD(.44,0,"DT")
 ;;=2930107
 ;;^DD(.44,0,"ID","WRITE")
 ;;=D:Y<1 EN^DDIOL("** DISTRIBUTED BY VA FILEMAN **","","?35")
 ;;^DD(.44,0,"IX","B",.44,.01)
 ;;=
 ;;^DD(.44,0,"IX","C",.441,.01)
 ;;=
 ;;^DD(.44,0,"NM","FOREIGN FORMAT")
 ;;=
 ;;^DD(.44,0,"PT",.4,105)
 ;;=
 ;;^DD(.44,.01,0)
 ;;=NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X
 ;;^DD(.44,.01,1,0)
 ;;=^.1
 ;;^DD(.44,.01,1,1,0)
 ;;=.44^B
 ;;^DD(.44,.01,1,1,1)
 ;;=S ^DIST(.44,"B",$E(X,1,30),DA)=""
 ;;^DD(.44,.01,1,1,2)
 ;;=K ^DIST(.44,"B",$E(X,1,30),DA)
 ;;^DD(.44,.01,3)
 ;;=Name must be 3-30 characters in length, not starting with punctuation.
 ;;^DD(.44,.01,21,0)
 ;;=^^1^1^2920914^
 ;;^DD(.44,.01,21,1,0)
 ;;=This field identifies the format used by the non-VA FileMan application.
 ;;^DD(.44,.01,"DEL",1,0)
 ;;=I DA<1
 ;;^DD(.44,.01,"DT")
 ;;=2920914
 ;;^DD(.44,1,0)
 ;;=FIELD DELIMITER^FX^^0;2^K:$L(X)>15!($L(X)<1)!'((X?1AP.E)!(X?3N)!(X?3N1","3N)!(X?3N1","3N1","3N)!(X?3N1","3N1","3N1","3N)) X
 ;;^DD(.44,1,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(.44,1,21,0)
 ;;=^^10^10^2921028^
 ;;^DD(.44,1,21,1,0)
 ;;=Contents of the field delimiter is output between each field.  Depending
 ;;^DD(.44,1,21,2,0)
 ;;=on the contents of the SEND LAST FIELD DELIMITER? field, the delimiter may
 ;;^DD(.44,1,21,3,0)
 ;;=be output after the last field, too. Identify the delimiter either by 1-15
 ;;^DD(.44,1,21,4,0)
 ;;=characters not beginning with a number or by the ASCII value of the
 ;;^DD(.44,1,21,5,0)
 ;;=delimiter.  When specifying the ASCII value, use 3 numbers (e.g., '009'
 ;;^DD(.44,1,21,6,0)
 ;;=for ASCII 9).  Up to four ASCII-character values can be specified,
 ;;^DD(.44,1,21,7,0)
 ;;=separated by commas.
 ;;^DD(.44,1,21,8,0)
 ;;= 
 ;;^DD(.44,1,21,9,0)
 ;;=If 'Ask' is entered, the user will be prompted for the field delimiter
 ;;^DD(.44,1,21,10,0)
 ;;=when creating the EXPORT template.
 ;;^DD(.44,1,"DT")
 ;;=2920914
 ;;^DD(.44,2,0)
 ;;=RECORD DELIMITER^F^^0;3^K:$L(X)>15!($L(X)<1)!'((X?1AP.E)!(X?3N)!(X?3N1","3N)!(X?3N1","3N1","3N)!(X?3N1","3N1","3N1","3N)) X
 ;;^DD(.44,2,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(.44,2,21,0)
 ;;=^^8^8^2921026^
 ;;^DD(.44,2,21,1,0)
 ;;=Contents of the record delimiter is output after each record.  Identify
 ;;^DD(.44,2,21,2,0)
 ;;=the delimiter either by 1-15 characters not beginning with a number or by
 ;;^DD(.44,2,21,3,0)
 ;;=the ASCII value of the delimiter.  When specifying the ASCII value, use 3
 ;;^DD(.44,2,21,4,0)
 ;;=numbers (e.g., '009' for ASCII 9).  Up to four ASCII-character values can
 ;;^DD(.44,2,21,5,0)
 ;;=be specified, separated by commas.
 ;;^DD(.44,2,21,6,0)
 ;;= 
 ;;^DD(.44,2,21,7,0)
 ;;=If 'Ask' is entered, the user is prompted for the record delimiter when
 ;;^DD(.44,2,21,8,0)
 ;;=creating the EXPORT template.
 ;;^DD(.44,2,"DT")
 ;;=2920914
 ;;^DD(.44,3,0)
 ;;=LINE CONTINUATION CHARACTER^F^^0;4^K:$L(X)>15!($L(X)<1) X
 ;;^DD(.44,3,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(.44,3,21,0)
 ;;=^^1^1^2921028^
 ;;^DD(.44,3,21,1,0)
 ;;=Not used yet.
 ;;^DD(.44,3,"DT")
 ;;=2920828
 ;;^DD(.44,4,0)
 ;;=LINE CONTINUATION LOCATION^S^e:END OF LINE;b:BEGINNING OF LINE;^0;5^Q
 ;;^DD(.44,4,21,0)
 ;;=^^1^1^2920917^
 ;;^DD(.44,4,21,1,0)
 ;;=Not used yet.
 ;;^DD(.44,4,"DT")
 ;;=2920828
 ;;^DD(.44,5,0)
 ;;=RECORD LENGTH FIXED?^S^1:YES;0:NO;^0;6^Q
 ;;^DD(.44,5,21,0)
 ;;=^^3^3^2920917^
 ;;^DD(.44,5,21,1,0)
 ;;=Enter YES if the fields will be fixed length causing a fixed length record
 ;;^DD(.44,5,21,2,0)
 ;;=to be created.  When the EXPORT template is created, the user is prompted
 ;;^DD(.44,5,21,3,0)
 ;;=for the length of each field in the TARGET file.
 ;;^DD(.44,5,"DT")
 ;;=2920828
 ;;^DD(.44,6,0)
 ;;=NEED FOREIGN FIELD NAMES?^S^1:YES;0:NO;^0;7^Q
 ;;^DD(.44,6,21,0)
 ;;=^^3^3^2921013^
 ;;^DD(.44,6,21,1,0)
 ;;=Answer YES if it is necessary to save the field names from the foreign
 ;;^DD(.44,6,21,2,0)
 ;;=file in the export file.  The user will be prompted for the names when the
 ;;^DD(.44,6,21,3,0)
 ;;=EXPORT template is created.
 ;;^DD(.44,6,"DT")
 ;;=2920828
 ;;^DD(.44,7,0)
 ;;=MAXIMUM OUTPUT LENGTH^NJ4,0^^0;8^K:+X'=X!(X>9999)!(X<0)!(X?.E1"."1N.N) X
 ;;^DD(.44,7,3)
 ;;=Type a Number between 0 and 9999, 0 Decimal Digits
 ;;^DD(.44,7,21,0)
 ;;=^^7^7^2921026^
 ;;^DD(.44,7,21,1,0)
 ;;=The maximum length of a "line" of output; maximum number of characters
 ;;^DD(.44,7,21,2,0)
 ;;=before a LINE FEED is issued.  For most exports, this will be the maximum
 ;;^DD(.44,7,21,3,0)
 ;;=record length.
 ;;^DD(.44,7,21,4,0)
 ;;= 

DINIT270
DINIT270 ;SFISC/DPC-LOAD OF FOREIGN FORMAT DD (CONT) ;1/4/94  13:37
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT271:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DD(.44,7,21,5,0)
 ;;=If 0 is entered, the user will be prompted for maximum length when
 ;;^DD(.44,7,21,6,0)
 ;;=creating the EXPORT template.  If nothing is entered, the default will be
 ;;^DD(.44,7,21,7,0)
 ;;=80.
 ;;^DD(.44,7,"DT")
 ;;=2921026
 ;;^DD(.44,8,0)
 ;;=QUOTE NON-NUMERIC FIELDS?^S^1:YES;0:NO;^0;10^Q
 ;;^DD(.44,8,3)
 ;;=Enter '1' for YES or '0' for NO.
 ;;^DD(.44,8,21,0)
 ;;=^^7^7^2921013^
 ;;^DD(.44,8,21,1,0)
 ;;=If you want the values of fields that have a data type other than numeric
 ;;^DD(.44,8,21,2,0)
 ;;=to be surrounded by quotation marks ("), set this field to YES.
 ;;^DD(.44,8,21,3,0)
 ;;= 
 ;;^DD(.44,8,21,4,0)
 ;;=NOTE:  Only numeric fields in the home file (including multiples) are
 ;;^DD(.44,8,21,5,0)
 ;;=automatically considered to have a numeric data type.  If you want the
 ;;^DD(.44,8,21,6,0)
 ;;=user to indicate which fields should be numeric, answer YES to the PROMPT
 ;;^DD(.44,8,21,7,0)
 ;;=FOR DATA TYPE? field.
 ;;^DD(.44,8,"DT")
 ;;=2921013
 ;;^DD(.44,9,0)
 ;;=PROMPT FOR DATA TYPE?^S^1:YES;0:NO;^0;11^Q
 ;;^DD(.44,9,3)
 ;;=Enter '1' for YES, '0' for NO.
 ;;^DD(.44,9,21,0)
 ;;=^^3^3^2921013^
 ;;^DD(.44,9,21,1,0)
 ;;=Answer YES if you want the user to be prompted for the data type of the
 ;;^DD(.44,9,21,2,0)
 ;;=various fields at the time that an export template is being created.
 ;;^DD(.44,9,21,3,0)
 ;;=Otherwise, the data types will be automatically  derived.
 ;;^DD(.44,9,"DT")
 ;;=2921013
 ;;^DD(.44,10,0)
 ;;=SEND LAST FIELD DELIMITER?^S^0:NO;1:YES;^0;12^Q
 ;;^DD(.44,10,3)
 ;;=Enter '1' for YES, '0' for NO.
 ;;^DD(.44,10,21,0)
 ;;=^^3^3^2921028^
 ;;^DD(.44,10,21,1,0)
 ;;=Enter NO if you do not want a field delimiter to be output after the last
 ;;^DD(.44,10,21,2,0)
 ;;=field in a record.  Enter YES if you do want a final field delimiter
 ;;^DD(.44,10,21,3,0)
 ;;=output.
 ;;^DD(.44,10,"DT")
 ;;=2921028
 ;;^DD(.44,20,0)
 ;;=FILE HEADER^FX^^1;E1,245^K:$L(X)>245!($L(X)<1) X I $E($G(X))'="""" K:DUZ(0)'="@" X D:$D(X) ^DIM
 ;;^DD(.44,20,3)
 ;;=Answer must be standard MUMPS code or a literal string in quotes.
 ;;^DD(.44,20,21,0)
 ;;=^^7^7^2921001^
 ;;^DD(.44,20,21,1,0)
 ;;=Use this field to produce output preceding the exported records.  This
 ;;^DD(.44,20,21,2,0)
 ;;=will become part of your exported data.
 ;;^DD(.44,20,21,3,0)
 ;;= 
 ;;^DD(.44,20,21,4,0)
 ;;=Enter either a literal string enclosed in quotation marks ("like this") or
 ;;^DD(.44,20,21,5,0)
 ;;=MUMPS code that will WRITE the desired output when XECUTED.  For example:
 ;;^DD(.44,20,21,6,0)
 ;;= 
 ;;^DD(.44,20,21,7,0)
 ;;=       W "EXPORT CREATED BY USER NUMBER: "_$G(DUZ)
 ;;^DD(.44,20,"DT")
 ;;=2921028
 ;;^DD(.44,25,0)
 ;;=FILE TRAILER^FX^^2;E1,245^K:$L(X)>245!($L(X)<1) X I $E($G(X))'="""" K:DUZ(0)'="@" X D:$D(X) ^DIM
 ;;^DD(.44,25,3)
 ;;=Answer must be standard MUMPS code or a literal string in quotes.
 ;;^DD(.44,25,21,0)
 ;;=^^7^7^2921001^
 ;;^DD(.44,25,21,1,0)
 ;;=Use this field to produce output following the the exported records.  This
 ;;^DD(.44,25,21,2,0)
 ;;=will become part of your exported data.
 ;;^DD(.44,25,21,3,0)
 ;;= 
 ;;^DD(.44,25,21,4,0)
 ;;=Enter either a literal string enclosed in quotation marks ("like this") or
 ;;^DD(.44,25,21,5,0)
 ;;=MUMPS code that will WRITE the desired output when XECUTED.  For example:
 ;;^DD(.44,25,21,6,0)
 ;;= 
 ;;^DD(.44,25,21,7,0)
 ;;=       W "EXPORT CREATED BY USER NUMBER: "_$G(DUZ)
 ;;^DD(.44,25,"DT")
 ;;=2921028
 ;;^DD(.44,27,0)
 ;;=DATE FORMAT^K^^6;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.44,27,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.44,27,9)
 ;;=@
 ;;^DD(.44,27,21,0)
 ;;=^^6^6^2920923^
 ;;^DD(.44,27,21,1,0)
 ;;=If you want dates output in VA FileMan's standard external date/time
 ;;^DD(.44,27,21,2,0)
 ;;=format, make NO entry in this field.
 ;;^DD(.44,27,21,3,0)
 ;;= 
 ;;^DD(.44,27,21,4,0)
 ;;=If you want another format, enter MUMPS code here. The variable X will
 ;;^DD(.44,27,21,5,0)
 ;;=contain the date/time in VA FileMan's internal format.  The MUMPS code
 ;;^DD(.44,27,21,6,0)
 ;;=should SET Y to the date/time in the format you desire.
 ;;^DD(.44,27,"DT")
 ;;=2920923
 ;;^DD(.44,30,0)
 ;;=DESCRIPTION^.447^^3;0
 ;;^DD(.44,30,21,0)
 ;;=^^1^1^2920917^
 ;;^DD(.44,30,21,1,0)
 ;;=A description of the foreign format.
 ;;^DD(.44,31,0)
 ;;=USAGE NOTES^.448^^4;0
 ;;^DD(.44,31,21,0)
 ;;=^^2^2^2920917^
 ;;^DD(.44,31,21,1,0)
 ;;=Information about the use of the format; for example, which commands on
 ;;^DD(.44,31,21,2,0)
 ;;=the foreign system should be used to load the file.

DINIT271
DINIT271 ;SFISC/DPC-LOAD OF FOREIGN FORMAT DD (END) ;9/9/94  12:56
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT27A:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(.44,"%D",0)
 ;;=^^3^3^2940908^
 ;;^DIC(.44,"%D",1,0)
 ;;=This file stores the characteristics of various file export formats,
 ;;^DIC(.44,"%D",2,0)
 ;;=which are used by the Export tool in building Export Templates to send
 ;;^DIC(.44,"%D",3,0)
 ;;=data to non-M systems.
 ;;^DD(.44,11,0)
 ;;=SUBSTITUTE FOR NULL^F^^0;13^K:$L(X)>15!($L(X)<1) X
 ;;^DD(.44,11,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(.44,11,21,0)
 ;;=^^5^5^2930107^
 ;;^DD(.44,11,21,1,0)
 ;;=This field only affects numeric values exported in a delimited format.
 ;;^DD(.44,11,21,2,0)
 ;;=If nothing is entered in this field, data values of null will cause
 ;;^DD(.44,11,21,3,0)
 ;;=nothing to be exported for that field in the particular record.  If you
 ;;^DD(.44,11,21,4,0)
 ;;=want something to be exported when the data value is null, enter the
 ;;^DD(.44,11,21,5,0)
 ;;=character or characters in this field.
 ;;^DD(.44,11,"DT")
 ;;=2930107
 ;;^DD(.44,40,0)
 ;;=FORMAT USED?^S^0:NO;1:YES;^0;9^Q
 ;;^DD(.44,40,21,0)
 ;;=^^2^2^2920925^
 ;;^DD(.44,40,21,1,0)
 ;;=When set to YES, this field means that this Foriegn Format entry has been
 ;;^DD(.44,40,21,2,0)
 ;;=used to create an Export Template.
 ;;^DD(.44,40,"DT")
 ;;=2920925
 ;;^DD(.44,50,0)
 ;;=OTHER NAME FOR FORMAT^.441^^5;0
 ;;^DD(.441,0)
 ;;=OTHER NAME FOR FORMAT SUB-FIELD^^1^2
 ;;^DD(.441,0,"DT")
 ;;=2920914
 ;;^DD(.441,0,"IX","B",.441,.01)
 ;;=
 ;;^DD(.441,0,"NM","OTHER NAME FOR FORMAT")
 ;;=
 ;;^DD(.441,0,"UP")
 ;;=.44
 ;;^DD(.441,.01,0)
 ;;=OTHER NAME FOR FORMAT^MF^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
 ;;^DD(.441,.01,1,0)
 ;;=^.1
 ;;^DD(.441,.01,1,1,0)
 ;;=.441^B
 ;;^DD(.441,.01,1,1,1)
 ;;=S ^DIST(.44,DA(1),5,"B",$E(X,1,30),DA)=""
 ;;^DD(.441,.01,1,1,2)
 ;;=K ^DIST(.44,DA(1),5,"B",$E(X,1,30),DA)
 ;;^DD(.441,.01,1,2,0)
 ;;=.44^C
 ;;^DD(.441,.01,1,2,1)
 ;;=S ^DIST(.44,"C",$E(X,1,30),DA(1),DA)=""
 ;;^DD(.441,.01,1,2,2)
 ;;=K ^DIST(.44,"C",$E(X,1,30),DA(1),DA)
 ;;^DD(.441,.01,1,2,"%D",0)
 ;;=^^1^1^2920917^
 ;;^DD(.441,.01,1,2,"%D",1,0)
 ;;=This cross reference allows look-up of formats based on OTHER NAMES.
 ;;^DD(.441,.01,1,2,"DT")
 ;;=2920917
 ;;^DD(.441,.01,3)
 ;;=Answer must be 3-30 characters in length.
 ;;^DD(.441,.01,21,0)
 ;;=^^2^2^2920917^
 ;;^DD(.441,.01,21,1,0)
 ;;=Another name by which the foreign format might be known.  This name can be
 ;;^DD(.441,.01,21,2,0)
 ;;=used to access the format.
 ;;^DD(.441,.01,"DT")
 ;;=2920917
 ;;^DD(.441,1,0)
 ;;=DESCRIPTION FOR OTHER NAME^.4411^^1;0
 ;;^DD(.441,1,21,0)
 ;;=^^1^1^2920917^
 ;;^DD(.441,1,21,1,0)
 ;;=Description and information about the format's other name.
 ;;^DD(.4411,0)
 ;;=DESCRIPTION FOR OTHER NAME SUB-FIELD^^.01^1
 ;;^DD(.4411,0,"DT")
 ;;=2920914
 ;;^DD(.4411,0,"NM","DESCRIPTION FOR OTHER NAME")
 ;;=
 ;;^DD(.4411,0,"UP")
 ;;=.441
 ;;^DD(.4411,.01,0)
 ;;=DESCRIPTION FOR OTHER NAME^W^^0;1^Q
 ;;^DD(.4411,.01,"DT")
 ;;=2920914
 ;;^DD(.447,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(.447,0,"DT")
 ;;=2920914
 ;;^DD(.447,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(.447,0,"UP")
 ;;=.44
 ;;^DD(.447,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(.447,.01,"DT")
 ;;=2920914
 ;;^DD(.448,0)
 ;;=USAGE NOTES SUB-FIELD^^.01^1
 ;;^DD(.448,0,"DT")
 ;;=2920914
 ;;^DD(.448,0,"NM","USAGE NOTES")
 ;;=
 ;;^DD(.448,0,"UP")
 ;;=.44
 ;;^DD(.448,.01,0)
 ;;=USAGE NOTES^W^^0;1^Q
 ;;^DD(.448,.01,"DT")
 ;;=2920914

DINIT27A
DINIT27A ;ISCSF/DPC - FOREIGN FORMAT 1-2-3 DATA PARSE;1/11/93  2:27 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27B S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.001,0)
 ;;=1-2-3 DATA PARSE^^^^^1^^240^1^^1^1
 ;;^DIST(.44,.001,1)
 ;;=W $$DP123^DDXPLIB(DDXPXTNO)
 ;;^DIST(.44,.001,3,0)
 ;;=^^4^4^2921106^
 ;;^DIST(.44,.001,3,1,0)
 ;;=This format produces fixed length records designed for import into Lotus
 ;;^DIST(.44,.001,3,2,0)
 ;;=1-2-3.  The user is prompted for data types.  A special header is created
 ;;^DIST(.44,.001,3,3,0)
 ;;=that is used by 1-2-3's Data Parser.  The maximum record length is 240
 ;;^DIST(.44,.001,3,4,0)
 ;;=characters.
 ;;^DIST(.44,.001,4,0)
 ;;=^^10^10^2921120^
 ;;^DIST(.44,.001,4,1,0)
 ;;=To import data into 1-2-3 from a file created with this format: 1) Use
 ;;^DIST(.44,.001,4,2,0)
 ;;=File->Import->Text and select the file.  2) The first line of the file
 ;;^DIST(.44,.001,4,3,0)
 ;;=contains the information for the data parser.  You must change this from a
 ;;^DIST(.44,.001,4,4,0)
 ;;=label, preceded by ', to a format, preceded by ||.  Edit the line to make
 ;;^DIST(.44,.001,4,5,0)
 ;;=this change.  3) Use Data->Parse.  The Input Column range should include
 ;;^DIST(.44,.001,4,6,0)
 ;;=all the imported data, including the format line.  Select a desired Output
 ;;^DIST(.44,.001,4,7,0)
 ;;=Range. Finally, select Go to format the data in the output range. Be sure
 ;;^DIST(.44,.001,4,8,0)
 ;;=your columns are wide enough to hold the data.  NOTE: dates will be
 ;;^DIST(.44,.001,4,9,0)
 ;;=changed into numbers, 1-2-3's internal representation of a date. You can
 ;;^DIST(.44,.001,4,10,0)
 ;;=make the date readable by using Range->Format->Date.
 ;;^DIST(.44,.001,5,0)
 ;;=^.441^1^1
 ;;^DIST(.44,.001,5,1,0)
 ;;=Lotus 1-2-3 Data Parse
 ;;^DIST(.44,.001,5,"B","Lotus 1-2-3 Data Parse",1)
 ;;=
 ;;^DIST(.44,.001,6)
 ;;=S Y=$E(X,6,7)_"-"_$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,+$E(X,4,5))_"-"_$E(X,2,3) S:$E(X)'=2 Y="NOT 1900s"

DINIT27B
DINIT27B ;ISCSF/DPC - FOREIGN FORMAT 1-2-3 IMPORT NUMBERS;1/11/93  2:34 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27C S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.002,0)
 ;;=1-2-3 IMPORT NUMBERS^032^^^^^^0^1^1^1^1^0
 ;;^DIST(.44,.002,3,0)
 ;;=^^9^9^2930107^
 ;;^DIST(.44,.002,3,1,0)
 ;;=This format exports data for use with LOTUS 1-2-3 spreadsheets.
 ;;^DIST(.44,.002,3,2,0)
 ;;=Non-numeric fields will be in quotes.  Each field will be separated by
 ;;^DIST(.44,.002,3,3,0)
 ;;=a space.  Null-valued numeric fields in the primary file will be converted
 ;;^DIST(.44,.002,3,4,0)
 ;;=to a zero ('0'). WARNING: If the value of a field that is not in the
 ;;^DIST(.44,.002,3,5,0)
 ;;=primary file or that is not defined in the VA FILEMAN data dictionary as
 ;;^DIST(.44,.002,3,6,0)
 ;;=numeric is null or zero, nothing is output. That is, a zero (0) is NOT
 ;;^DIST(.44,.002,3,7,0)
 ;;=output.  This will destroy the positional results of the data and will
 ;;^DIST(.44,.002,3,8,0)
 ;;=install data in incorrect columns!!  If this situation is possible, do NOT
 ;;^DIST(.44,.002,3,9,0)
 ;;=use this format; consider the 123 DATA PARSE format.
 ;;^DIST(.44,.002,4,0)
 ;;=^^4^4^2930107^
 ;;^DIST(.44,.002,4,1,0)
 ;;=To import into 1-2-3, choose FILE->IMPORT->NUMBERS.
 ;;^DIST(.44,.002,4,2,0)
 ;;=Field values will automatically be placed into columns.
 ;;^DIST(.44,.002,4,3,0)
 ;;=Lotus 1-2-3 will automatically recognize your file for import if it has an
 ;;^DIST(.44,.002,4,4,0)
 ;;=extension of '.PRN'.
 ;;^DIST(.44,.002,5,0)
 ;;=^.441^1^1
 ;;^DIST(.44,.002,5,1,0)
 ;;=LOTUS 123 (NUMBERS)
 ;;^DIST(.44,.002,5,"B","LOTUS 123 (NUMBERS)",1)
 ;;=

DINIT27C
DINIT27C ;SFISC/DPC-FOREIGN FORMAT EXCEL(COMMA) ;11/30/92  3:39 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27D S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.003,0)
 ;;=EXCEL (COMMA)^,^^^^^^1000^1^1^1^1
 ;;^DIST(.44,.003,3,0)
 ;;=^^6^6^2921120^
 ;;^DIST(.44,.003,3,1,0)
 ;;=Use this format to export data to the EXCEL spreadsheet running
 ;;^DIST(.44,.003,3,2,0)
 ;;=on the Macintosh or under Windows.  The exported data will have a comma
 ;;^DIST(.44,.003,3,3,0)
 ;;=between each field's value.  The user will be asked to specify the data
 ;;^DIST(.44,.003,3,4,0)
 ;;=type of each exported field.  Those fields that are not numeric will be
 ;;^DIST(.44,.003,3,5,0)
 ;;=surrounded by quotes (").  Commas are allowed in the non-numeric data, but
 ;;^DIST(.44,.003,3,6,0)
 ;;=quotes (") are not.
 ;;^DIST(.44,.003,4,0)
 ;;=^^3^3^2921120^^^^
 ;;^DIST(.44,.003,4,1,0)
 ;;=Select the Open command on Excel's File menu.  Press the TEXT button and
 ;;^DIST(.44,.003,4,2,0)
 ;;=make sure that the Column Delimiter is set to "comma."  Select the file.
 ;;^DIST(.44,.003,4,3,0)
 ;;=Each field's values will be imported into columns.
 ;;^DIST(.44,.003,5,0)
 ;;=^.441^2^2
 ;;^DIST(.44,.003,5,1,0)
 ;;=COMMA DELIMITED
 ;;^DIST(.44,.003,5,1,1,0)
 ;;=^^2^2^2921015^
 ;;^DIST(.44,.003,5,1,1,1,0)
 ;;=Exported data is delimited by commas.  Non-numeric data is surrounded by
 ;;^DIST(.44,.003,5,1,1,2,0)
 ;;=quotes.
 ;;^DIST(.44,.003,5,2,0)
 ;;=CSV
 ;;^DIST(.44,.003,5,2,1,0)
 ;;=^^1^1^2921120^^
 ;;^DIST(.44,.003,5,2,1,1,0)
 ;;=Comma Separated Values.
 ;;^DIST(.44,.003,5,"B","COMMA DELIMITED",1)
 ;;=
 ;;^DIST(.44,.003,5,"B","CSV",2)
 ;;=

DINIT27D
DINIT27D ;SFISC/DPC-FOREIGN FORMAT EXCEL(DATA PARSE) ;11/30/92  3:42 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27E S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.004,0)
 ;;=EXCEL (DATA PARSE)^^^^^1^^255^1^^^1
 ;;^DIST(.44,.004,1)
 ;;=W $$DPXCEL^DDXPLIB(DDXPXTNO)
 ;;^DIST(.44,.004,3,0)
 ;;=^^4^4^2921120^
 ;;^DIST(.44,.004,3,1,0)
 ;;=Use the EXCEL-DATA PARSE format to export data to the EXCEL spreadsheet
 ;;^DIST(.44,.004,3,2,0)
 ;;=program running on the Macintosh or under windows.  Exported data is fixed
 ;;^DIST(.44,.004,3,3,0)
 ;;=length.  The first line output is a guide for use by EXCEL's Data Parser
 ;;^DIST(.44,.004,3,4,0)
 ;;=to place data into columns.  Maximum record length is 255 characters.
 ;;^DIST(.44,.004,4,0)
 ;;=^^7^7^2921120^
 ;;^DIST(.44,.004,4,1,0)
 ;;=To import a file created in this format into Excel, choose the Open
 ;;^DIST(.44,.004,4,2,0)
 ;;=command on the File menu and select the file.  Each record will be put
 ;;^DIST(.44,.004,4,3,0)
 ;;=into a single cell.  Select the column that has the data, including the
 ;;^DIST(.44,.004,4,4,0)
 ;;=first record which will contain the guide for data parsing.  Then, choose
 ;;^DIST(.44,.004,4,5,0)
 ;;=Parse from the Data menu.  Press the GUESS button and then press OK.  The
 ;;^DIST(.44,.004,4,6,0)
 ;;=data will be put into correct columns.  You may need to adjust column
 ;;^DIST(.44,.004,4,7,0)
 ;;=widths.

DINIT27E
DINIT27E ;SFISC/DPC-FOREIGN FORMAT EXCEL(TAB) ;11/30/92  3:44 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27F S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.005,0)
 ;;=EXCEL (TAB)^009^^^^^^^1^^^1
 ;;^DIST(.44,.005,3,0)
 ;;=^^2^2^2921120^
 ;;^DIST(.44,.005,3,1,0)
 ;;=Format used to export data to EXCEL spreadsheet running on the Macintosh
 ;;^DIST(.44,.005,3,2,0)
 ;;=or under Windows.  A <TAB> is placed between each field's value.
 ;;^DIST(.44,.005,4,0)
 ;;=^^6^6^2921120^^^
 ;;^DIST(.44,.005,4,1,0)
 ;;=Select the Open command on Excel's File menu.  Press the TEXT button and
 ;;^DIST(.44,.005,4,2,0)
 ;;=make sure that the Column Delimiter is set to "TAB."  Select the file.
 ;;^DIST(.44,.005,4,3,0)
 ;;=Each field's values will be imported into columns.
 ;;^DIST(.44,.005,4,4,0)
 ;;=If you are capturing data to make your export file, be sure that the <TAB>
 ;;^DIST(.44,.005,4,5,0)
 ;;=(ASCII value 009) is not converted to spaces by your communications
 ;;^DIST(.44,.005,4,6,0)
 ;;=software.
 ;;^DIST(.44,.005,5,0)
 ;;=^.441^1^1
 ;;^DIST(.44,.005,5,1,0)
 ;;=Tab Delimited
 ;;^DIST(.44,.005,5,1,1,0)
 ;;=^^1^1^2921120^^
 ;;^DIST(.44,.005,5,1,1,1,0)
 ;;=A <TAB> is placed between each field's value.
 ;;^DIST(.44,.005,5,"B","Tab Delimited",1)
 ;;=

DINIT27F
DINIT27F ;SFISC/DPC-EIGN FORMAT WORD (COMMA) ;11/30/92  3:46 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27G S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.006,0)
 ;;=WORD DATA FILE (COMMA)^,^^^^^1^250^1^1^^0
 ;;^DIST(.44,.006,1)
 ;;=W $$FLDNM^DDXPLIB(DDXPXTNO)
 ;;^DIST(.44,.006,3,0)
 ;;=^^5^5^2921106^
 ;;^DIST(.44,.006,3,1,0)
 ;;=The format creates records with comma delimited fields.  Non-numeric
 ;;^DIST(.44,.006,3,2,0)
 ;;=fields are in quotes.  The user is prompted for field names that are
 ;;^DIST(.44,.006,3,3,0)
 ;;=output as the first line of the exported file.
 ;;^DIST(.44,.006,3,4,0)
 ;;=This format was designed to be used to create a Data File for use with
 ;;^DIST(.44,.006,3,5,0)
 ;;=Microsoft Word's Print Merge utility.
 ;;^DIST(.44,.006,4,0)
 ;;=^^6^6^2921106^
 ;;^DIST(.44,.006,4,1,0)
 ;;=Use the exported file as the Data File for Microsoft Word's Print Merge
 ;;^DIST(.44,.006,4,2,0)
 ;;=utility.  The Merge Field names are contained in the first line of exported
 ;;^DIST(.44,.006,4,3,0)
 ;;=data.  See the Word documentation and Descriptions of Other Names for
 ;;^DIST(.44,.006,4,4,0)
 ;;=instructions for importing into various versions of Word.
 ;;^DIST(.44,.006,4,5,0)
 ;;=(Note: Word does not allow spaces and some other punctuation in the Merge
 ;;^DIST(.44,.006,4,6,0)
 ;;=Field names.)
 ;;^DIST(.44,.006,5,0)
 ;;=^.441^3^3
 ;;^DIST(.44,.006,5,1,0)
 ;;=WORD 5.0 (MACINTOSH)
 ;;^DIST(.44,.006,5,1,1,0)
 ;;=^^7^7^2921106^
 ;;^DIST(.44,.006,5,1,1,1,0)
 ;;=To use the exported file as a Data File:
 ;;^DIST(.44,.006,5,1,1,2,0)
 ;;=1) With Main Document open, select Print Merge Helper on the View menu and
 ;;^DIST(.44,.006,5,1,1,3,0)
 ;;=choose the exported file as the Data File.
 ;;^DIST(.44,.006,5,1,1,4,0)
 ;;=2)From the Insert Field Names box on the Print Merge Helper bar, insert
 ;;^DIST(.44,.006,5,1,1,5,0)
 ;;=the field names into the Main Document.
 ;;^DIST(.44,.006,5,1,1,6,0)
 ;;=3)Select Print Merge from the File menu to merge the exported data into
 ;;^DIST(.44,.006,5,1,1,7,0)
 ;;=the Main Document.
 ;;^DIST(.44,.006,5,2,0)
 ;;=WORD 4.0 (MACINTOSH)
 ;;^DIST(.44,.006,5,2,1,0)
 ;;=^^8^8^2921106^
 ;;^DIST(.44,.006,5,2,1,1,0)
 ;;=To use the exported file as a Data file:
 ;;^DIST(.44,.006,5,2,1,2,0)
 ;;=1)Into the main document enter the Merge Instruction 'DATA' followed by
 ;;^DIST(.44,.006,5,2,1,3,0)
 ;;=the file name of your exported file surrounded by Merge Quotes.
 ;;^DIST(.44,.006,5,2,1,4,0)
 ;;=2)Enter your field names in the Main Document.  The names must match
 ;;^DIST(.44,.006,5,2,1,5,0)
 ;;=exactly those on the first line of the Data (exported) file and be
 ;;^DIST(.44,.006,5,2,1,6,0)
 ;;=surrounded by Merge Quotes (<OPTION-\> AND <OPTION-SHIFT-\>).
 ;;^DIST(.44,.006,5,2,1,7,0)
 ;;=3)Select Print Merge from the File menu to merge the data into the Main
 ;;^DIST(.44,.006,5,2,1,8,0)
 ;;=Document.
 ;;^DIST(.44,.006,5,3,0)
 ;;=WINWORD 2.0
 ;;^DIST(.44,.006,5,3,1,0)
 ;;=^^7^7^2921106^
 ;;^DIST(.44,.006,5,3,1,1,0)
 ;;=To use the exported file as the Data file:
 ;;^DIST(.44,.006,5,3,1,2,0)
 ;;=1) With the Main Document open, select Print Merge from the File menu and
 ;;^DIST(.44,.006,5,3,1,3,0)
 ;;=press Attach Data File button.  Select your exported file as the Data
 ;;^DIST(.44,.006,5,3,1,4,0)
 ;;=file.
 ;;^DIST(.44,.006,5,3,1,5,0)
 ;;=2) Use the Insert Merge Fields box to place Merge Fields in the Main
 ;;^DIST(.44,.006,5,3,1,6,0)
 ;;=Document.
 ;;^DIST(.44,.006,5,3,1,7,0)
 ;;=3) Again select Print Merge from the File menu and press the Merge button.
 ;;^DIST(.44,.006,5,"B","WINWORD 2.0",3)
 ;;=
 ;;^DIST(.44,.006,5,"B","WORD 4.0 (MACINTOSH)",2)
 ;;=
 ;;^DIST(.44,.006,5,"B","WORD 5.0 (MACINTOSH)",1)
 ;;=

DINIT27G
DINIT27G ;SFISC/DPC-FOREIGN FORMAT WORD(TAB) ;11/30/92  3:50 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27H S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.007,0)
 ;;=WORD DATA FILE (TAB)^009^^^^^1^250^1^1^^0
 ;;^DIST(.44,.007,1)
 ;;=W $$FLDNM^DDXPLIB(DDXPXTNO)
 ;;^DIST(.44,.007,3,0)
 ;;=^^5^5^2921106^
 ;;^DIST(.44,.007,3,1,0)
 ;;=The format creates records with <TAB> delimited fields.  Non-numeric
 ;;^DIST(.44,.007,3,2,0)
 ;;=fields are in quotes.  The user is prompted for field names that are
 ;;^DIST(.44,.007,3,3,0)
 ;;=output as the first line of the exported file.
 ;;^DIST(.44,.007,3,4,0)
 ;;=This format was designed to be used to create a Data File for use with
 ;;^DIST(.44,.007,3,5,0)
 ;;=Microsoft Word's Print Merge utility.
 ;;^DIST(.44,.007,4,0)
 ;;=^^6^6^2921106^
 ;;^DIST(.44,.007,4,1,0)
 ;;=Use the exported file as the Data File for Microsoft Word's Print Merge
 ;;^DIST(.44,.007,4,2,0)
 ;;=utility.  The Merge Field names are contained in the first line of exported
 ;;^DIST(.44,.007,4,3,0)
 ;;=data.  See the Word documentation and Descriptions of Other Names for
 ;;^DIST(.44,.007,4,4,0)
 ;;=instructions for importing into various versions of Word.
 ;;^DIST(.44,.007,4,5,0)
 ;;=(Note: Word does not allow spaces and some other punctuation in the Merge
 ;;^DIST(.44,.007,4,6,0)
 ;;=Field names.)
 ;;^DIST(.44,.007,5,0)
 ;;=^.441^3^3
 ;;^DIST(.44,.007,5,1,0)
 ;;=WORD 5.0 (MACINTOSH)
 ;;^DIST(.44,.007,5,1,1,0)
 ;;=^^7^7^2921106^
 ;;^DIST(.44,.007,5,1,1,1,0)
 ;;=To use the exported file as a Data File:
 ;;^DIST(.44,.007,5,1,1,2,0)
 ;;=1) With Main Document open, select Print Merge Helper on the View menu and
 ;;^DIST(.44,.007,5,1,1,3,0)
 ;;=choose the exported file as the Data File.
 ;;^DIST(.44,.007,5,1,1,4,0)
 ;;=2)From the Insert Field Names box on the Print Merge Helper bar, insert
 ;;^DIST(.44,.007,5,1,1,5,0)
 ;;=the field names into the Main Document.
 ;;^DIST(.44,.007,5,1,1,6,0)
 ;;=3)Select Print Merge from the File menu to merge the exported data into
 ;;^DIST(.44,.007,5,1,1,7,0)
 ;;=the Main Document.
 ;;^DIST(.44,.007,5,2,0)
 ;;=WORD 4.0 (MACINTOSH)
 ;;^DIST(.44,.007,5,2,1,0)
 ;;=^^8^8^2921106^
 ;;^DIST(.44,.007,5,2,1,1,0)
 ;;=To use the exported file as a Data file:
 ;;^DIST(.44,.007,5,2,1,2,0)
 ;;=1)Into the main document enter the Merge Instruction 'DATA' followed by
 ;;^DIST(.44,.007,5,2,1,3,0)
 ;;=the file name of your exported file surrounded by Merge Quotes.
 ;;^DIST(.44,.007,5,2,1,4,0)
 ;;=2)Enter your field names in the Main Document.  The names must match
 ;;^DIST(.44,.007,5,2,1,5,0)
 ;;=exactly those on the first line of the Data (exported) file and be
 ;;^DIST(.44,.007,5,2,1,6,0)
 ;;=surrounded by Merge Quotes (<OPTION-\> AND <OPTION-SHIFT-\>).
 ;;^DIST(.44,.007,5,2,1,7,0)
 ;;=3)Select Print Merge from the File menu to merge the data into the Main
 ;;^DIST(.44,.007,5,2,1,8,0)
 ;;=Document.
 ;;^DIST(.44,.007,5,3,0)
 ;;=WINWORD 2.0
 ;;^DIST(.44,.007,5,3,1,0)
 ;;=^^7^7^2921106^
 ;;^DIST(.44,.007,5,3,1,1,0)
 ;;=To use the exported file as the Data file:
 ;;^DIST(.44,.007,5,3,1,2,0)
 ;;=1) With the Main Document open, select Print Merge from the File menu and
 ;;^DIST(.44,.007,5,3,1,3,0)
 ;;=press Attach Data File button.  Select your exported file as the Data
 ;;^DIST(.44,.007,5,3,1,4,0)
 ;;=file.
 ;;^DIST(.44,.007,5,3,1,5,0)
 ;;=2) Use the Insert Merge Fields box to place Merge Fields in the Main
 ;;^DIST(.44,.007,5,3,1,6,0)
 ;;=Document.
 ;;^DIST(.44,.007,5,3,1,7,0)
 ;;=3) Again select Print Merge from the File menu and press the Merge button.
 ;;^DIST(.44,.007,5,"B","WINWORD 2.0",3)
 ;;=
 ;;^DIST(.44,.007,5,"B","WORD 4.0 (MACINTOSH)",2)
 ;;=
 ;;^DIST(.44,.007,5,"B","WORD 5.0 (MACINTOSH)",1)
 ;;=

DINIT27H
DINIT27H ;SFISC/DPC -FOREIGN FORMAT DELIMITED ;11/30/92  3:51 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27I S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.998,0)
 ;;=USER DEFINED (DELIMITED)^ASK^ask^^^^^0^1^^^1
 ;;^DIST(.44,.998,3,0)
 ;;=^^3^3^2921120^
 ;;^DIST(.44,.998,3,1,0)
 ;;=User will be prompted for field and record delimiters and for the maximum
 ;;^DIST(.44,.998,3,2,0)
 ;;=length of an exported record.  A field delimiter is mandatory; a record
 ;;^DIST(.44,.998,3,3,0)
 ;;=delimiter is optional.

DINIT27I
DINIT27I ;SFISC/DPC-FOREIGN FORMAT USER FIXED ;2/26/93  10:57 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27J S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.999,0)
 ;;=USER DEFINED (FIXED LENGTH)^^^^^1^^0^1^^^1
 ;;^DIST(.44,.999,3,0)
 ;;=^^2^2^2921120^
 ;;^DIST(.44,.999,3,1,0)
 ;;=The export will consist of fixed length records.  User will be prompted
 ;;^DIST(.44,.999,3,2,0)
 ;;=for the length of each field and for the maximum record length.
 ;;^DIST(.44,.999,4,0)
 ;;=^^4^4^2921120^
 ;;^DIST(.44,.999,4,1,0)
 ;;=The user-supplied maximum record length must be greater than the sum of
 ;;^DIST(.44,.999,4,2,0)
 ;;=the lengths of all the exported fields.  Date values will not be
 ;;^DIST(.44,.999,4,3,0)
 ;;=truncated; the record length must be at least 11 characters to hold the VA
 ;;^DIST(.44,.999,4,4,0)
 ;;=FileMan external form of the date.
 ;;^DIST(.44,.999,5,0)
 ;;=^.441^^

DINIT27J
DINIT27J ;SFISC/DPC - ORACLE (FIXED FORMAT) FOREIGN FORMAT;2/26/93  10:59 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT27K S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.008,0)
 ;;=ORACLE (FIXED FORMAT)^^^^^1^1^255^1^^^1
 ;;^DIST(.44,.008,1)
 ;;=D ORACTL^DDXPLIB
 ;;^DIST(.44,.008,3,0)
 ;;=^^5^5^2930125^
 ;;^DIST(.44,.008,3,1,0)
 ;;=Use this format to export data to an Oracle table.  Data will be exported
 ;;^DIST(.44,.008,3,2,0)
 ;;=in fixed format.  The user will be prompted for the length of each field
 ;;^DIST(.44,.008,3,3,0)
 ;;=and the field name.  By default, the data will be imported into an Oracle
 ;;^DIST(.44,.008,3,4,0)
 ;;=table with the same name as the export template used to export the data.
 ;;^DIST(.44,.008,3,5,0)
 ;;=The field names should be the column_names in the Oracle table.
 ;;^DIST(.44,.008,4,0)
 ;;=^^14^14^2930125^
 ;;^DIST(.44,.008,4,1,0)
 ;;=This format produces a control file to be used with Oracle's SQL*LOADER
 ;;^DIST(.44,.008,4,2,0)
 ;;=utility to load data into a preexisting Oracle table.  The control file is
 ;;^DIST(.44,.008,4,3,0)
 ;;=complete as created, but you may edit the file to modify the import.  By
 ;;^DIST(.44,.008,4,4,0)
 ;;=default, the data will be imported into a table with the same name as that
 ;;^DIST(.44,.008,4,5,0)
 ;;=of the export template.  Spaces in the export template name will be
 ;;^DIST(.44,.008,4,6,0)
 ;;=converted to underscores (_). So, either that table must exist in your
 ;;^DIST(.44,.008,4,7,0)
 ;;=Oracle table_space with the columns specified when the export template was
 ;;^DIST(.44,.008,4,8,0)
 ;;=built or the exported file will need to be modified to show the correct
 ;;^DIST(.44,.008,4,9,0)
 ;;=table_name.  A minimum syntax for loading an export file named
 ;;^DIST(.44,.008,4,10,0)
 ;;=INTO_ORACLE.CTL would be:
 ;;^DIST(.44,.008,4,11,0)
 ;;=|TAB|
 ;;^DIST(.44,.008,4,12,0)
 ;;=       SQLLOAD USERID=username/password, CONTROL=INTO_ORACLE.CTL|TAB|
 ;;^DIST(.44,.008,4,13,0)
 ;;= 
 ;;^DIST(.44,.008,4,14,0)
 ;;=Of course, other options are available.  Consult your Oracle documentation.
 ;;^DIST(.44,.008,5,0)
 ;;=^.441^^

DINIT27K
DINIT27K ;SFISC/DPC - ORACLE (DELIMITED) FOREIGN FORMAT;6/10/93  13:35
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT28 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.009,0)
 ;;=ORACLE (DELIMITED)^,^^^^0^1^0^1^1^^1
 ;;^DIST(.44,.009,1)
 ;;=D ORACTL^DDXPLIB
 ;;^DIST(.44,.009,3,0)
 ;;=^^7^7^2930125^
 ;;^DIST(.44,.009,3,1,0)
 ;;=Use this format to export data to an Oracle table.  Data will be exported
 ;;^DIST(.44,.009,3,2,0)
 ;;=in comma-delimited format and non-numeric fields will be surrounded by
 ;;^DIST(.44,.009,3,3,0)
 ;;=quotes.  The user will be prompted for field names.  The field names
 ;;^DIST(.44,.009,3,4,0)
 ;;=should be the column_names in the Oracle table.  Also, the user will need
 ;;^DIST(.44,.009,3,5,0)
 ;;=to supply the maximum length of a record to be exported.  By default, data
 ;;^DIST(.44,.009,3,6,0)
 ;;=will be imported into a table with the same name as that of the export
 ;;^DIST(.44,.009,3,7,0)
 ;;=template.
 ;;^DIST(.44,.009,4,0)
 ;;=^^13^13^2930125^
 ;;^DIST(.44,.009,4,1,0)
 ;;=This format produces a control file to be used with Oracle's SQL*LOADER
 ;;^DIST(.44,.009,4,2,0)
 ;;=utility to load data into a preexisting Oracle table.  The control file is
 ;;^DIST(.44,.009,4,3,0)
 ;;=complete as created, but you may edit the file to modify the import.  By
 ;;^DIST(.44,.009,4,4,0)
 ;;=default, the data will be imported into a table with the same name as that
 ;;^DIST(.44,.009,4,5,0)
 ;;=of the export template.  So, either that table must exist in your Oracle
 ;;^DIST(.44,.009,4,6,0)
 ;;=table_space with the columns specified when the export template was built
 ;;^DIST(.44,.009,4,7,0)
 ;;=or the exported file will need to be modified to show the correct
 ;;^DIST(.44,.009,4,8,0)
 ;;=table_name.  A minimum syntax for loading an export file named
 ;;^DIST(.44,.009,4,9,0)
 ;;=INTO_ORACLE.CTL would be:
 ;;^DIST(.44,.009,4,10,0)
 ;;= |TAB|
 ;;^DIST(.44,.009,4,11,0)
 ;;=       SQLLOAD USERID=username/password, CONTROL=INTO_ORACLE.CTL|TAB|
 ;;^DIST(.44,.009,4,12,0)
 ;;= 
 ;;^DIST(.44,.009,4,13,0)
 ;;=Of course, other options are available.  Consult your Oracle documentation.
 ;;^DIST(.44,.009,5,0)
 ;;=^.441^^

DINIT27L
DINIT27L ;SFISC/DPC - SAS (COLUMNS) FOREIGN FORMAT;2/26/93  11:05 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT28 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
 Q
ENTRY ;
 ;;^DIST(.44,.011,0)
 ;;=SAS (COLUMNS)^^^^^1^1^0^1^^1^1
 ;;^DIST(.44,.011,1)
 ;;=D SASCOL^DDXPLIB
 ;;^DIST(.44,.011,2)
 ;;=";"
 ;;^DIST(.44,.011,3,0)
 ;;=^^5^5^2921229^
 ;;^DIST(.44,.011,3,1,0)
 ;;=This format creates output designed for use with SAS.  The output is
 ;;^DIST(.44,.011,3,2,0)
 ;;=column-oriented.  The user is prompted for field lengths, maximum record
 ;;^DIST(.44,.011,3,3,0)
 ;;=length, field names (used as SAS variable names), and data types.  Field
 ;;^DIST(.44,.011,3,4,0)
 ;;=length for date data types must be 8 or larger.  No semicolons (;) may
 ;;^DIST(.44,.011,3,5,0)
 ;;=appear in the data.
 ;;^DIST(.44,.011,4,0)
 ;;=^^6^6^2930226^^^
 ;;^DIST(.44,.011,4,1,0)
 ;;=The exported output begins with an INPUT statement that contains variable
 ;;^DIST(.44,.011,4,2,0)
 ;;=names as specified by the user.  For numeric and free text (character)
 ;;^DIST(.44,.011,4,3,0)
 ;;=data, the start and end columns are shown.  For date data, the informat
 ;;^DIST(.44,.011,4,4,0)
 ;;='YYMMDDw.' is used with data always given YYYYMMDD (i.e., full century
 ;;^DIST(.44,.011,4,5,0)
 ;;=data).  Following the INPUT statement is a 'CARDS;' line, followed by the
 ;;^DIST(.44,.011,4,6,0)
 ;;=columnar data, followed by ';'.
 ;;^DIST(.44,.011,5,0)
 ;;=^.441^^
 ;;^DIST(.44,.011,6)
 ;;=S Y=X+17000000

DINIT28
DINIT28 ;SFISC/XAK-INITIALIZE VA FILEMAN ;9/9/94  14:19
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G ^DINIT285:X="" S Y=$E($T(Q+I+1),5,999),X=$E(X,4,999),@X=Y
Q Q
 ;;^DIC(1.12,0,"GL")
 ;;=^DIAR(1.12,
 ;;^DIC("B","FILEGRAM HISTORY",1.12)
 ;;=
 ;;^DIC(1.12,"%D",0)
 ;;=^^1^1^2930712^
 ;;^DIC(1.12,"%D",1,0)
 ;;=This file stores information and status of filegram activities.
 ;;^DD(1.12,0)
 ;;=FIELD^^.07^7
 ;;^DD(1.12,0,"ID",.03)
 ;;=W "   ",$P(^(0),U,3)
 ;;^DD(1.12,0,"ID",.04)
 ;;=S %I=Y,Y=$S('$D(^(0)):"",$D(^DIC(+$P(^(0),U,4),0))#2:$P(^(0),U,1),1:""),C=$P(^DD(1,.01,0),U,2) D Y^DIQ:Y]"" W "   ",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I
 ;;^DD(1.12,0,"IX","B",1.12,.01)
 ;;=
 ;;^DD(1.12,.01,0)
 ;;=DATE/TIME^RDX^^0;1^S %DT="ETX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(1.12,.01,1,0)
 ;;=^.1
 ;;^DD(1.12,.01,1,1,0)
 ;;=1.12^B
 ;;^DD(1.12,.01,1,1,1)
 ;;=S ^DIAR(1.12,"B",$E(X,1,30),DA)=""
 ;;^DD(1.12,.01,1,1,2)
 ;;=K ^DIAR(1.12,"B",$E(X,1,30),DA)
 ;;^DD(1.12,.01,3)
 ;;=
 ;;^DD(1.12,.02,0)
 ;;=SENT/INSTALLED^RS^s:SENT;i:INSTALLED;u:UNSUCCESSFUL;^0;2^Q
 ;;^DD(1.12,.03,0)
 ;;=USER^RF^^0;3^K:$L(X)>30!($L(X)<1) X
 ;;^DD(1.12,.03,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(1.12,.04,0)
 ;;=FILE^P1'^DIC(^0;4^Q
 ;;^DD(1.12,.05,0)
 ;;=ENTRY NUMBER^RNJ8,0^^0;5^K:+X'=X!(X>99999999)!(X<.001)!(X?.E1"."1N.N) X
 ;;^DD(1.12,.05,3)
 ;;=Type a Number between .001 and 99999999, 0 Decimal Digits
 ;;^DD(1.12,.06,0)
 ;;=MESSAGE^P3.9'^XMB(3.9,^0;6^Q
 ;;^DD(1.12,.07,0)
 ;;=FILEGRAM^P.4'^DIPT(^0;7^Q

DINIT285
DINIT285 ;SFISC/TKW-ALTERNATE EDITOR FILE ;9/9/94  14:33
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT286 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC("B","ALTERNATE EDITOR",1.2)
 ;;=
 ;;^DIC(1.2,"%D",0)
 ;;=^^6^6^2940908^
 ;;^DIC(1.2,"%D",1,0)
 ;;=This file stores information about the editors that can be used to edit VA
 ;;^DIC(1.2,"%D",2,0)
 ;;=FileMan WP fields. The LINE EDITOR and SCREEN EDITOR are exported with VA
 ;;^DIC(1.2,"%D",3,0)
 ;;=FileMan, but instructions are given to allow site managers to enter local
 ;;^DIC(1.2,"%D",4,0)
 ;;=editors of their choice.  There is a pointer in the NEW PERSON File to
 ;;^DIC(1.2,"%D",5,0)
 ;;=this file.  The pointed-to editor for that person is then used whenever
 ;;^DIC(1.2,"%D",6,0)
 ;;=the person edits a WP field.
 ;;^DD(1.2,0)
 ;;=FIELD^NL^7^5
 ;;^DD(1.2,0,"IX","B",1.2,.01)
 ;;=
 ;;^DD(1.2,0,"NM","ALTERNATE EDITOR")
 ;;=
 ;;^DD(1.2,0,"PT",200,31.3)
 ;;=
 ;;^DD(1.2,.01,0)
 ;;=NAME^RFX^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X I $D(X) S %=$O(^DIST(1.2,"B",$E(X))) I $E(%)=$E(X) K X
 ;;^DD(1.2,.01,1,0)
 ;;=^.1
 ;;^DD(1.2,.01,1,1,0)
 ;;=1.2^B
 ;;^DD(1.2,.01,1,1,1)
 ;;=S ^DIST(1.2,"B",$E(X,1,30),DA)=""
 ;;^DD(1.2,.01,1,1,2)
 ;;=K ^DIST(1.2,"B",$E(X,1,30),DA)
 ;;^DD(1.2,.01,3)
 ;;=NAME MUST BE 3-30 CHAR., and start with a unique alpha char.
 ;;^DD(1.2,.01,21,0)
 ;;=2^^2^2^2920506^^^
 ;;^DD(1.2,.01,21,1,0)
 ;;=This is the name of the alternate editor. It must start with a unique
 ;;^DD(1.2,.01,21,2,0)
 ;;=character.
 ;;^DD(1.2,.01,"DT")
 ;;=2901212
 ;;^DD(1.2,1,0)
 ;;=ACTIVATION CODE FROM DIWE^RK^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(1.2,1,3)
 ;;=This is Standard MUMPS code, used to set up the environment for editing a Standard FileMan word-processing field using this editor.
 ;;^DD(1.2,1,9)
 ;;=@
 ;;^DD(1.2,1,21,0)
 ;;=^^17^17^2920513^^^^
 ;;^DD(1.2,1,21,1,0)
 ;;=This field holds the MUMPS code to properly establish the environment
 ;;^DD(1.2,1,21,2,0)
 ;;=that will allow use of this editor to edit any VA FileMan word-processing
 ;;^DD(1.2,1,21,3,0)
 ;;=type field.  Typically this code might move the text into another
 ;;^DD(1.2,1,21,4,0)
 ;;=MUMPS global (like ^UTILITY) or to some other file format for editing.
 ;;^DD(1.2,1,21,5,0)
 ;;=If the editor is written in MUMPS, it should either use variables that
 ;;^DD(1.2,1,21,6,0)
 ;;=do not begin with the letter "D", or should NEW all its local variables
 ;;^DD(1.2,1,21,7,0)
 ;;=to avoid problems on return to the FileMan editor.
 ;;^DD(1.2,1,21,8,0)
 ;;=
 ;;^DD(1.2,1,21,9,0)
 ;;=If the variable DIWE(1) is defined, it indicated that the user
 ;;^DD(1.2,1,21,10,0)
 ;;=has switched to this editor from the standard FileMan Line Editor, and
 ;;^DD(1.2,1,21,11,0)
 ;;=upon return, the control will be returned to the line editor.
 ;;^DD(1.2,1,21,12,0)
 ;;=
 ;;^DD(1.2,1,21,13,0)
 ;;=This editor may set the variable DIWESW to 1, if they wish to allow
 ;;^DD(1.2,1,21,14,0)
 ;;=the user to switch to an alternate editor from this one.
 ;;^DD(1.2,1,21,15,0)
 ;;=
 ;;^DD(1.2,1,21,16,0)
 ;;=This editor is required to restore the edited text to standard FileMan
 ;;^DD(1.2,1,21,17,0)
 ;;=word-processing format before exiting.
 ;;^DD(1.2,1,"DT")
 ;;=2900202
 ;;^DD(1.2,2,0)
 ;;=OK TO RUN TEST^K^^2;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(1.2,2,3)
 ;;=This is Standard MUMPS code that sets $T to true if it is OK to use this editor.
 ;;^DD(1.2,2,9)
 ;;=@
 ;;^DD(1.2,2,21,0)
 ;;=^^9^9^2920513^^^^
 ;;^DD(1.2,2,21,1,0)
 ;;=This field holds MUMPS code used to pre-check the environment before
 ;;^DD(1.2,2,21,2,0)
 ;;=allowing the user to enter this editor.  This field should set the
 ;;^DD(1.2,2,21,3,0)
 ;;=$TEST indicator.  If $TEST is true then it is OK for this editor to
 ;;^DD(1.2,2,21,4,0)
 ;;=run at this time.  If $T is false, the user will be returned to the
 ;;^DD(1.2,2,21,5,0)
 ;;=FileMan line editor.
 ;;^DD(1.2,2,21,6,0)
 ;;=
 ;;^DD(1.2,2,21,7,0)
 ;;=If the field is null, it will be the same as $T=true

DINIT286
DINIT286 ;SFISC/TKW-ALTERNATE EDITOR FILE ;5/27/92  1:56 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT287 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(1.2,2,21,8,0)
 ;;=
 ;;^DD(1.2,2,21,9,0)
 ;;=An example would be a mixed VAX-PDP site using a VMS editor.
 ;;^DD(1.2,2,"DT")
 ;;=2900202
 ;;^DD(1.2,3,0)
 ;;=RETURN TO CALLING EDITOR^K^^3;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(1.2,3,3)
 ;;=This is Standard MUMPS code used to restore the environment needed by the VA FileMan line editor.
 ;;^DD(1.2,3,9)
 ;;=@
 ;;^DD(1.2,3,21,0)
 ;;=^^3^3^2920513^^^^
 ;;^DD(1.2,3,21,1,0)
 ;;=If the user switched to this editor from the FileMan line editor, then
 ;;^DD(1.2,3,21,2,0)
 ;;=DIWE(1) exists.  This field should contain MUMPS code used to reset
 ;;^DD(1.2,3,21,3,0)
 ;;=the environment needed by the Line Editor.
 ;;^DD(1.2,3,"DT")
 ;;=2900202
 ;;^DD(1.2,7,0)
 ;;=DESCRIPTION^1.207^^7;0
 ;;^DD(1.2,7,21,0)
 ;;=^^3^3^2920506^^^^
 ;;^DD(1.2,7,21,1,0)
 ;;=This is a description of the editor that will be shown to the user
 ;;^DD(1.2,7,21,2,0)
 ;;=if they enter ??? at the Select prompt.
 ;;^DD(1.2,7,21,3,0)
 ;;=Not in use yet.
 ;;^DD(1.207,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(1.207,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(1.207,0,"UP")
 ;;=1.2
 ;;^DD(1.207,.01,0)
 ;;=DESCRIPTION^WL^^0;1^Q
 ;;^DD(1.207,.01,"DT")
 ;;=2900202

DINIT287
DINIT287 ;SFISC/MLH ALTERNATE EDITOR FILE ;5/27/92  2:27 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
 G ^DINIT290
Q Q
 ;;^DIST(1.2,0)
 ;;=ALTERNATE EDITOR^1.2^9^8
 ;;^DIST(1.2,1,0)
 ;;=LINE EDITOR - VA FILEMAN
 ;;^DIST(1.2,1,1)
 ;;=G GO^DIWE
 ;;^DIST(1.2,2,0)
 ;;=SCREEN EDITOR - VA FILEMAN
 ;;^DIST(1.2,2,1)
 ;;=D ^DDW
 ;;^DIST(1.2,2,7,0)
 ;;=^^2^2^2901212^^^
 ;;^DIST(1.2,2,7,1,0)
 ;;=
 ;;^DIST(1.2,2,7,2,0)
 ;;=The standard VA FileMan full-screen text editor.

DINIT290
DINIT290 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT291 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC("B","FORM",.403)
 ;;=
 ;;^DIC(.403,"%D",0)
 ;;=^^3^3^2940914^
 ;;^DIC(.403,"%D",1,0)
 ;;=This file stores ScreenMan forms, which are composed of blocks.  The
 ;;^DIC(.403,"%D",2,0)
 ;;=form's attributes that describe how information is presented on the screen
 ;;^DIC(.403,"%D",3,0)
 ;;=are contained in this file.
 ;;^DD(.403,0)
 ;;=FIELD^^6^18
 ;;^DD(.403,0,"DT")
 ;;=2941018
 ;;^DD(.403,0,"ID","WRITE")
 ;;=N D,D1,D2 S D2=^(0) S:$X>30 D1(1,"F")="!" S D=$P(D2,U,5) S:D D1(2)="("_$$FMTE^DILIBF(D)_")",D1(2,"F")="?30" S D=$P(D2,U,4) S:D D1(3)="User #"_D,D1(3,"F")="?50" S D=$P(D2,U,8) S:D D1(4)=" File #"_D,D1(4,"F")="?59" D EN^DDIOL(.D1)
 ;;^DD(.403,0,"ID","WRITED")
 ;;=I $G(DZ)?1"???".E N D S D=0 F  S D=$O(^DIST(.403,Y,15,D)) Q:D'>0  I $D(^(D,0))#2 D EN^DDIOL(^(0),"","!?5")
 ;;^DD(.403,0,"IX","AB",.4032,.01)
 ;;=
 ;;^DD(.403,0,"IX","AC",.4031,1)
 ;;=
 ;;^DD(.403,0,"IX","AZ",.403,.01)
 ;;=
 ;;^DD(.403,0,"IX","B",.403,.01)
 ;;=
 ;;^DD(.403,0,"IX","C",.403,6)
 ;;=
 ;;^DD(.403,0,"IX","F",.403,7)
 ;;=
 ;;^DD(.403,0,"IX","F1",.403,.01)
 ;;=
 ;;^DD(.403,0,"NM","FORM")
 ;;=
 ;;^DD(.403,.01,0)
 ;;=NAME^RFX^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3)!'(X'?1P.E)!(X=+$P(X,"E")) X
 ;;^DD(.403,.01,1,0)
 ;;=^.1
 ;;^DD(.403,.01,1,1,0)
 ;;=.403^B
 ;;^DD(.403,.01,1,1,1)
 ;;=S ^DIST(.403,"B",$E(X,1,30),DA)=""
 ;;^DD(.403,.01,1,1,2)
 ;;=K ^DIST(.403,"B",$E(X,1,30),DA)
 ;;^DD(.403,.01,1,2,0)
 ;;=.403^F1^MUMPS
 ;;^DD(.403,.01,1,2,1)
 ;;=X "S %=$P("_DIC_"DA,0),U,8) S:$L(%) "_DIC_"""F""_%,X,DA)=1"
 ;;^DD(.403,.01,1,2,2)
 ;;=X "S %=$P("_DIC_"DA,0),U,8) K:$L(%) "_DIC_"""F""_%,X,DA)"
 ;;^DD(.403,.01,1,2,3)
 ;;=Programmer only
 ;;^DD(.403,.01,1,2,"%D",0)
 ;;=^^6^6^2910812^
 ;;^DD(.403,.01,1,2,"%D",1,0)
 ;;=This cross-reference is used to quickly find all ScreenMan templates
 ;;^DD(.403,.01,1,2,"%D",2,0)
 ;;=associated with a file.  It has the form:
 ;;^DD(.403,.01,1,2,"%D",3,0)
 ;;=
 ;;^DD(.403,.01,1,2,"%D",4,0)
 ;;=  ^DIST(.403,"F"_file#,"formname",DA)=1
 ;;^DD(.403,.01,1,2,"%D",5,0)
 ;;=
 ;;^DD(.403,.01,1,2,"%D",6,0)
 ;;=A comparable cross-reference also exists on the PRIMARY FILE field.
 ;;^DD(.403,.01,1,2,"DT")
 ;;=2910812
 ;;^DD(.403,.01,1,3,0)
 ;;=.403^AZ^MUMPS
 ;;^DD(.403,.01,1,3,1)
 ;;=Q
 ;;^DD(.403,.01,1,3,2)
 ;;=Q
 ;;^DD(.403,.01,1,3,3)
 ;;=Programmer only
 ;;^DD(.403,.01,1,3,"%D",0)
 ;;=^^7^7^2940708^
 ;;^DD(.403,.01,1,3,"%D",1,0)
 ;;=This is a no-op cross reference defined merely to document the data stored
 ;;^DD(.403,.01,1,3,"%D",2,0)
 ;;=under ^DIST(.403,form IEN,"AZ").
 ;;^DD(.403,.01,1,3,"%D",3,0)
 ;;= 
 ;;^DD(.403,.01,1,3,"%D",4,0)
 ;;=This global stores the compiled data for a Form.  Form compilation occurs
 ;;^DD(.403,.01,1,3,"%D",5,0)
 ;;=automatically whenever a Form is edited through the FileMan supplied
 ;;^DD(.403,.01,1,3,"%D",6,0)
 ;;=options.  The compiled data stored in this global is static information
 ;;^DD(.403,.01,1,3,"%D",7,0)
 ;;=that is used whenever a Form is run.
 ;;^DD(.403,.01,1,3,"DT")
 ;;=2940708
 ;;^DD(.403,.01,3)
 ;;=Answer must be 3-30 characters in length.
 ;;^DD(.403,.01,21,0)
 ;;=^^3^3^2940906^
 ;;^DD(.403,.01,21,1,0)
 ;;=Enter the name of the form, 3-30 characters in length.  The form name
 ;;^DD(.403,.01,21,2,0)
 ;;=must be unique and cannot be numeric or start with a punctuation
 ;;^DD(.403,.01,21,3,0)
 ;;=character.  It should also be namespaced.
 ;;^DD(.403,.01,"DEL",1,0)
 ;;=D EN^DDIOL($C(7)_"You must use the FileMan option to delete forms.") I 1
 ;;^DD(.403,.01,"DT")
 ;;=2940708
 ;;^DD(.403,1,0)
 ;;=READ ACCESS^FX^^0;2^I DUZ(0)'="@" N DDZ F DDZ=1:1:$L(X) K:DUZ(0)'[$E(X,DDZ) X
 ;;^DD(.403,1,3)
 ;;=Enter VA FileMan access code(s) which control access to the form.
 ;;^DD(.403,1,21,0)
 ;;=^^1^1^2931020^^
 ;;^DD(.403,1,21,1,0)
 ;;=Non-programmers can enter only their own VA FileMan access code(s).
 ;;^DD(.403,1,"DT")
 ;;=2931020
 ;;^DD(.403,2,0)
 ;;=WRITE ACCESS^FX^^0;3^I DUZ(0)'="@" N DDZ F DDZ=1:1:$L(X) K:DUZ(0)'[$E(X,DDZ) X
 ;;^DD(.403,2,3)
 ;;=Enter VA FileMan access code(s) which control access to the form.
 ;;^DD(.403,2,21,0)
 ;;=^^1^1^2931020^
 ;;^DD(.403,2,21,1,0)
 ;;=Non-programmers can enter only their own VA FileMan access code(s).
 ;;^DD(.403,2,"DT")
 ;;=2931020
 ;;^DD(.403,3,0)
 ;;=CREATOR^NJ3,0X^^0;4^K:X'?.N X
 ;;^DD(.403,3,3)
 ;;=Enter the VA FileMan User Number of the form creator.
 ;;^DD(.403,3,21,0)
 ;;=^^2^2^2931020^^

DINIT291
DINIT291 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT292 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.403,3,21,1,0)
 ;;=This is the DUZ of the person who created the form.  The ScreenMan
 ;;^DD(.403,3,21,2,0)
 ;;=options to create the form automatically put a value into this field.
 ;;^DD(.403,4,0)
 ;;=DATE CREATED^D^^0;5^S %DT="ETX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(.403,4,3)
 ;;=Enter the date the form was created.
 ;;^DD(.403,4,21,0)
 ;;=^^2^2^2941018^^
 ;;^DD(.403,4,21,1,0)
 ;;=This is the date the form was created.  The ScreenMan options to create
 ;;^DD(.403,4,21,2,0)
 ;;=the form automatically put a value into this field.
 ;;^DD(.403,4,"DT")
 ;;=2941018
 ;;^DD(.403,5,0)
 ;;=DATE LAST USED^D^^0;6^S %DT="ETX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(.403,5,3)
 ;;=Enter the date and time the form was last used.
 ;;^DD(.403,5,21,0)
 ;;=^^2^2^2941018^^
 ;;^DD(.403,5,21,1,0)
 ;;=This is the date the form was last used.  ScreenMan automatically
 ;;^DD(.403,5,21,2,0)
 ;;=puts a value into this field when the form is invoked.
 ;;^DD(.403,5,"DT")
 ;;=2941018
 ;;^DD(.403,6,0)
 ;;=TITLE^F^^0;7^K:$L(X)>50!($L(X)<1) X
 ;;^DD(.403,6,1,0)
 ;;=^.1
 ;;^DD(.403,6,1,1,0)
 ;;=.403^C
 ;;^DD(.403,6,1,1,1)
 ;;=S ^DIST(.403,"C",$E(X,1,30),DA)=""
 ;;^DD(.403,6,1,1,2)
 ;;=K ^DIST(.403,"C",$E(X,1,30),DA)
 ;;^DD(.403,6,1,1,"DT")
 ;;=2940908
 ;;^DD(.403,6,3)
 ;;=Answer must be 1-50 characters in length.
 ;;^DD(.403,6,21,0)
 ;;=^^4^4^2940908^
 ;;^DD(.403,6,21,1,0)
 ;;=The TITLE property can be used by the form designer to help identify a
 ;;^DD(.403,6,21,2,0)
 ;;=form.  It is cross referenced and need not be unique.  ScreenMan does not
 ;;^DD(.403,6,21,3,0)
 ;;=automatically display the TITLE to the user, but the form designer can
 ;;^DD(.403,6,21,4,0)
 ;;=choose to define a caption-only field that displays the title to the user.
 ;;^DD(.403,6,22)
 ;;=
 ;;^DD(.403,6,"DT")
 ;;=2940908
 ;;^DD(.403,7,0)
 ;;=PRIMARY FILE^RFX^^0;8^K:X'=+$P(X,"E")!(X<2)!($L(X)>16)!'$D(^DIC(X)) X
 ;;^DD(.403,7,1,0)
 ;;=^.1
 ;;^DD(.403,7,1,1,0)
 ;;=.403^F^MUMPS
 ;;^DD(.403,7,1,1,1)
 ;;=X "S %=$P("_DIC_"DA,0),U) S "_DIC_"""F""_X,%,DA)=1"
 ;;^DD(.403,7,1,1,2)
 ;;=X "S %=$P("_DIC_"DA,0),U) K "_DIC_"""F""_X,%,DA)"
 ;;^DD(.403,7,1,1,3)
 ;;=Programmer only
 ;;^DD(.403,7,1,1,"%D",0)
 ;;=^^2^2^2900911^
 ;;^DD(.403,7,1,1,"%D",0,"LE")
 ;;=1
 ;;^DD(.403,7,1,1,"%D",1,0)
 ;;=This cross-reference is used to quickly find all ScreenMan templates
 ;;^DD(.403,7,1,1,"%D",2,0)
 ;;=associated with a file.
 ;;^DD(.403,7,1,1,"DT")
 ;;=2900911
 ;;^DD(.403,7,3)
 ;;=Answer must be 1-16 characters in length.
 ;;^DD(.403,7,21,0)
 ;;=^^2^2^2920407^
 ;;^DD(.403,7,21,1,0)
 ;;=Enter a file number, greater than or equal to 2, which represents the data
 ;;^DD(.403,7,21,2,0)
 ;;=dictionary number of the primary file for this form.
 ;;^DD(.403,7,"DT")
 ;;=2920407
 ;;^DD(.403,8,0)
 ;;=DISPLAY ONLY^SI^0:NO;1:YES;^0;9^Q
 ;;^DD(.403,8,21,0)
 ;;=^^2^2^2931027^^^^
 ;;^DD(.403,8,21,1,0)
 ;;=This is a flag that indicates none of the blocks on the form are edit
 ;;^DD(.403,8,21,2,0)
 ;;=blocks.  This flag is set during form compilation.
 ;;^DD(.403,8,"DT")
 ;;=2931028
 ;;^DD(.403,9,0)
 ;;=FORM ONLY^SI^0:NO;1:YES;^0;10^Q
 ;;^DD(.403,9,21,0)
 ;;=^^2^2^2931027^
 ;;^DD(.403,9,21,1,0)
 ;;=This is a flag that indicates none of the fields on the form are data
 ;;^DD(.403,9,21,2,0)
 ;;=dictionary fields.  This flag is set during form compilation.
 ;;^DD(.403,9,"DT")
 ;;=2931028
 ;;^DD(.403,10,0)
 ;;=COMPILED^SI^0:NO;1:YES;^0;11^Q
 ;;^DD(.403,10,1,0)
 ;;=^.1^^0
 ;;^DD(.403,10,21,0)
 ;;=^^2^2^2940908^
 ;;^DD(.403,10,21,1,0)
 ;;=This is a flag that indicates that the form is compiled.  This flag is
 ;;^DD(.403,10,21,2,0)
 ;;=set during form compilation.
 ;;^DD(.403,10,"DT")
 ;;=2940701
 ;;^DD(.403,11,0)
 ;;=PRE ACTION^K^^11;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.403,11,3)
 ;;=Enter standard MUMPS code which will be executed at the beginning of the form.
 ;;^DD(.403,11,9)
 ;;=@
 ;;^DD(.403,11,21,0)
 ;;=^^2^2^2940906^
 ;;^DD(.403,11,21,1,0)
 ;;=This is MUMPS code that is executed when the form is first invoked,
 ;;^DD(.403,11,21,2,0)
 ;;=before any of the pages are loaded and displayed.
 ;;^DD(.403,12,0)
 ;;=POST ACTION^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.403,12,3)
 ;;=Enter standard MUMPS code which will be executed at the end of the form.
 ;;^DD(.403,12,9)
 ;;=@
 ;;^DD(.403,12,21,0)
 ;;=^^2^2^2940906^^
 ;;^DD(.403,12,21,1,0)
 ;;=This is MUMPS code that is executed before ScreenMan returns to the
 ;;^DD(.403,12,21,2,0)
 ;;=calling application.

DINIT292
DINIT292 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT293 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.403,14,0)
 ;;=POST SAVE^K^^14;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.403,14,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.403,14,9)
 ;;=@
 ;;^DD(.403,14,21,0)
 ;;=^^2^2^2940906^
 ;;^DD(.403,14,21,1,0)
 ;;=This is MUMPS code that is executed when the user saves changes.  It is 
 ;;^DD(.403,14,21,2,0)
 ;;=executed only if all data is valid, and after all data has been filed.
 ;;^DD(.403,14,"DT")
 ;;=2930813
 ;;^DD(.403,15,0)
 ;;=DESCRIPTION^.40315^^15;0
 ;;^DD(.403,20,0)
 ;;=DATA VALIDATION^K^^20;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.403,20,3)
 ;;=Enter standard MUMPS code.
 ;;^DD(.403,20,9)
 ;;=@
 ;;^DD(.403,20,21,0)
 ;;=^^8^8^2940906^
 ;;^DD(.403,20,21,1,0)
 ;;=This is MUMPS code that is executed when the user attempts to save changes
 ;;^DD(.403,20,21,2,0)
 ;;=to the form.  If the code sets DDSERROR, the user is unable to save
 ;;^DD(.403,20,21,3,0)
 ;;=changes.  If the code sets DDSBR, the user is taken to the specified
 ;;^DD(.403,20,21,4,0)
 ;;=field.
 ;;^DD(.403,20,21,5,0)
 ;;= 
 ;;^DD(.403,20,21,6,0)
 ;;=In addition to $$GET^DDSVAL, PUT^DDSVAL, and HLP^DDSUTL, you 
 ;;^DD(.403,20,21,7,0)
 ;;=can use MSG^DDSUTL to print on a separate screen messages to the user 
 ;;^DD(.403,20,21,8,0)
 ;;=about the validity of the data.
 ;;^DD(.403,21,0)
 ;;=RECORD SELECTION PAGE^NJ5,1^^21;1^K:+X'=X!(X>999.9)!(X<1)!(X?.E1"."2N.N) X
 ;;^DD(.403,21,3)
 ;;=Type a Number between 1 and 999.9, 1 Decimal Digit
 ;;^DD(.403,21,21,0)
 ;;=^^12^12^2940906^
 ;;^DD(.403,21,21,1,0)
 ;;=Enter the page number of the page that is used for record selection.
 ;;^DD(.403,21,21,2,0)
 ;;= 
 ;;^DD(.403,21,21,3,0)
 ;;=If you define a Record Selection Page, the user can select another entry
 ;;^DD(.403,21,21,4,0)
 ;;=in the file, and, if LAYGO is allowed, add another entry into the file
 ;;^DD(.403,21,21,5,0)
 ;;=without exiting the form.  The Record Selection Page should be a pop-up
 ;;^DD(.403,21,21,6,0)
 ;;=page that contains one form-only field that performs a pointer-type read
 ;;^DD(.403,21,21,7,0)
 ;;=into the Primary File of the form.  The Record Selection Page property
 ;;^DD(.403,21,21,8,0)
 ;;=should be set equal to the Page Number of the Record Selection Page.
 ;;^DD(.403,21,21,9,0)
 ;;= 
 ;;^DD(.403,21,21,10,0)
 ;;=The user can open the Record Selection Page by pressing <PF1>L.  After the
 ;;^DD(.403,21,21,11,0)
 ;;=user selects a record and closes the Record Selection Page, the data for
 ;;^DD(.403,21,21,12,0)
 ;;=the selected record is displayed.
 ;;^DD(.403,21,"DT")
 ;;=2930225
 ;;^DD(.403,40,0)
 ;;=PAGE^.4031I^^40;0
 ;;^DD(.403,40,"DT")
 ;;=2930218
 ;;^DD(.4031,0)
 ;;=PAGE SUB-FIELD^^40^13
 ;;^DD(.4031,0,"DT")
 ;;=2940506
 ;;^DD(.4031,0,"ID","WRITE")
 ;;=D:$D(^(1))#2 EN^DDIOL($P(^(1),U),"","?12")
 ;;^DD(.4031,0,"IX","AC",.4031,5)
 ;;=
 ;;^DD(.4031,0,"IX","B",.4031,.01)
 ;;=
 ;;^DD(.4031,0,"IX","C",.4031,7)
 ;;=
 ;;^DD(.4031,0,"NM","PAGE")
 ;;=
 ;;^DD(.4031,0,"UP")
 ;;=.403
 ;;^DD(.4031,.01,0)
 ;;=PAGE NUMBER^MNJ5,1X^^0;1^K:+X'=X!(X>999.9)!(X<1)!(X?.E1"."2N.N)!$D(^DIST(.403,DA(1),40,"B",X)) X
 ;;^DD(.4031,.01,1,0)
 ;;=^.1
 ;;^DD(.4031,.01,1,1,0)
 ;;=.4031^B
 ;;^DD(.4031,.01,1,1,1)
 ;;=S ^DIST(.403,DA(1),40,"B",$E(X,1,30),DA)=""
 ;;^DD(.4031,.01,1,1,2)
 ;;=K ^DIST(.403,DA(1),40,"B",$E(X,1,30),DA)
 ;;^DD(.4031,.01,3)
 ;;=Enter a number between 1 and 999.9, up to 1 Decimal Digit, that identifies the page.
 ;;^DD(.4031,.01,21,0)
 ;;=^^2^2^2940907^^^
 ;;^DD(.4031,.01,21,1,0)
 ;;=This is the unique page number of the page.  You can use this number to
 ;;^DD(.4031,.01,21,2,0)
 ;;=refer to the page in ScreenMan functions and utilities.
 ;;^DD(.4031,1,0)
 ;;=HEADER BLOCK^P.404^DIST(.404,^0;2^Q
 ;;^DD(.4031,1,1,0)
 ;;=^.1
 ;;^DD(.4031,1,1,1,0)
 ;;=.403^AC
 ;;^DD(.4031,1,1,1,1)
 ;;=S ^DIST(.403,"AC",$E(X,1,30),DA(1),DA)=""
 ;;^DD(.4031,1,1,1,2)
 ;;=K ^DIST(.403,"AC",$E(X,1,30),DA(1),DA)
 ;;^DD(.4031,1,1,1,"DT")
 ;;=2930702
 ;;^DD(.4031,1,3)
 ;;=Enter the block which will be used as a header for this page.
 ;;^DD(.4031,1,21,0)
 ;;=^^7^7^2940907^^^
 ;;^DD(.4031,1,21,1,0)
 ;;=The header block always appears at row 1, column 1 relative to the page
 ;;^DD(.4031,1,21,2,0)
 ;;=on which it is defined.  It is for display purposes only -- the user
 ;;^DD(.4031,1,21,3,0)
 ;;=is unable to navigate to any of the fields on the header block.
 ;;^DD(.4031,1,21,4,0)
 ;;= 
 ;;^DD(.4031,1,21,5,0)
 ;;=Starting with Version 21 of FileMan, there is no need to use header

DINIT293
DINIT293 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT294 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4031,1,21,6,0)
 ;;=blocks.  Display-type blocks, with a coordinate of '1,1' relative to the
 ;;^DD(.4031,1,21,7,0)
 ;;=page, provide the same functionality as header blocks.
 ;;^DD(.4031,1,"DT")
 ;;=2930702
 ;;^DD(.4031,2,0)
 ;;=PAGE COORDINATE^F^^0;3^K:$L(X)>7!($L(X)<1)!'(X?.N1",".N) X
 ;;^DD(.4031,2,3)
 ;;=Enter the coordinate of the upper left corner of the page.  Answer must be two positive integers separated by a comma (,), as follows:  'Upper left row,Upper left column'.
 ;;^DD(.4031,2,21,0)
 ;;=^^13^13^2940908^
 ;;^DD(.4031,2,21,1,0)
 ;;=The Page Coordinate property defines the location of the top left corner
 ;;^DD(.4031,2,21,2,0)
 ;;=of the page on the screen.  The format of a coordinate is:  Row,Column.
 ;;^DD(.4031,2,21,3,0)
 ;;=Regular pages normally have a Page Coordinate of  "1,1".  They do not have
 ;;^DD(.4031,2,21,4,0)
 ;;=a Lower Right Coordinate.
 ;;^DD(.4031,2,21,5,0)
 ;;= 
 ;;^DD(.4031,2,21,6,0)
 ;;=The Page Coordinate of pop-up pages defines the position of the top left
 ;;^DD(.4031,2,21,7,0)
 ;;=corner of the border of the pop-up page.  Pop-up pages must have a Lower
 ;;^DD(.4031,2,21,8,0)
 ;;=Right Coordinate, which defines the position of the bottom right corner of
 ;;^DD(.4031,2,21,9,0)
 ;;=the border of the pop-up page.
 ;;^DD(.4031,2,21,10,0)
 ;;= 
 ;;^DD(.4031,2,21,11,0)
 ;;=All blocks on the page are positioned relative to the page on which they
 ;;^DD(.4031,2,21,12,0)
 ;;=are defined.  If a page is moved -- that is, if the Page Coordinate is
 ;;^DD(.4031,2,21,13,0)
 ;;=changed -- all blocks and all fields on that page move with it.
 ;;^DD(.4031,2,"DT")
 ;;=2940908
 ;;^DD(.4031,3,0)
 ;;=NEXT PAGE^NJ5,1^^0;4^K:+X'=X!(X>999.9)!(X<1)!(X?.E1"."2N.N) X
 ;;^DD(.4031,3,3)
 ;;=Answer must be a Number between 1 and 999.9, 1 Decimal Digit.
 ;;^DD(.4031,3,21,0)
 ;;=^^9^9^2940908^
 ;;^DD(.4031,3,21,1,0)
 ;;=Enter the page to go to when the user presses <PF1><Down> or selects the
 ;;^DD(.4031,3,21,2,0)
 ;;=NEXT PAGE command from the Command Line.
 ;;^DD(.4031,3,21,3,0)
 ;;= 
 ;;^DD(.4031,3,21,4,0)
 ;;=When the user attempts a Save, ScreenMan follows the Next Page links
 ;;^DD(.4031,3,21,5,0)
 ;;=starting with the first page displayed to the user.  ScreenMan loads all
 ;;^DD(.4031,3,21,6,0)
 ;;=those pages, including any defaults, and checks that all required fields
 ;;^DD(.4031,3,21,7,0)
 ;;=have values.  If any of the required fields have null values, no Save
 ;;^DD(.4031,3,21,8,0)
 ;;=occurs.  If all required field have values, Screenman Saves the data,
 ;;^DD(.4031,3,21,9,0)
 ;;=including all defaults.
 ;;^DD(.4031,4,0)
 ;;=PREVIOUS PAGE^NJ5,1^^0;5^K:+X'=X!(X>999.9)!(X<1)!(X?.E1"."2N.N) X
 ;;^DD(.4031,4,3)
 ;;=Answer must be a Number between 1 and 999.9, 1 Decimal Digit.
 ;;^DD(.4031,4,21,0)
 ;;=^^1^1^2940907^
 ;;^DD(.4031,4,21,1,0)
 ;;=Enter the page to go to when the user presses <PF1><Up>.
 ;;^DD(.4031,5,0)
 ;;=IS THIS A POP UP PAGE?^S^0:NO;1:YES;^0;6^Q
 ;;^DD(.4031,5,1,0)
 ;;=^.1
 ;;^DD(.4031,5,1,1,0)
 ;;=.4031^AC^MUMPS
 ;;^DD(.4031,5,1,1,1)
 ;;=S:X $P(^DIST(.403,DA(1),40,DA,0),U,2)=""
 ;;^DD(.4031,5,1,1,2)
 ;;=Q
 ;;^DD(.4031,5,1,1,3)
 ;;=Programmer only
 ;;^DD(.4031,5,1,1,"%D",0)
 ;;=^^1^1^2940627^
 ;;^DD(.4031,5,1,1,"%D",1,0)
 ;;=If this is a pop up page, there can be no header block.
 ;;^DD(.4031,5,1,1,"DT")
 ;;=2940627
 ;;^DD(.4031,5,3)
 ;;=
 ;;^DD(.4031,5,21,0)
 ;;=^^8^8^2940908^
 ;;^DD(.4031,5,21,1,0)
 ;;=If the page is a pop-up page rather than a regular page, set this property
 ;;^DD(.4031,5,21,2,0)
 ;;=to 'YES'.
 ;;^DD(.4031,5,21,3,0)
 ;;= 
 ;;^DD(.4031,5,21,4,0)
 ;;=ScreenMan displays pop-up pages with a border, on top of what is
 ;;^DD(.4031,5,21,5,0)
 ;;=already on the screen.  The top left coordinate of the pop-up page
 ;;^DD(.4031,5,21,6,0)
 ;;=defines the location of the top left corner of the border.  Pop-up
 ;;^DD(.4031,5,21,7,0)
 ;;=pages must also have a lower right coordinate, which defines the location
 ;;^DD(.4031,5,21,8,0)
 ;;=of the bottom left corner of the border.
 ;;^DD(.4031,5,"DT")
 ;;=2940627
 ;;^DD(.4031,6,0)
 ;;=LOWER RIGHT COORDINATE^F^^0;7^K:$L(X)>7!($L(X)<1)!'(X?.N1",".N) X
 ;;^DD(.4031,6,3)
 ;;=Enter the coordinate of the bottom right corner of the pop up page.  Answer must be two positive integers separated by a comma (,), as follows:  'Lower right row,Lower right column'.
 ;;^DD(.4031,6,21,0)
 ;;=^^4^4^2940908^

DINIT294
DINIT294 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT295 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4031,6,21,1,0)
 ;;=The existence of a lower right coordinate implies that the page is a
 ;;^DD(.4031,6,21,2,0)
 ;;=pop-up page.  The lower right coordinate and the page coordinate define
 ;;^DD(.4031,6,21,3,0)
 ;;=the position of the border ScreenMan displays when it paints a pop-up
 ;;^DD(.4031,6,21,4,0)
 ;;=page.
 ;;^DD(.4031,6,"DT")
 ;;=2940908
 ;;^DD(.4031,7,0)
 ;;=PAGE NAME^FX^^1;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3)!(X=+$P(X,"E")) X
 ;;^DD(.4031,7,1,0)
 ;;=^.1
 ;;^DD(.4031,7,1,1,0)
 ;;=.4031^C^MUMPS
 ;;^DD(.4031,7,1,1,1)
 ;;=S ^DIST(.403,DA(1),40,"C",$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)=""
 ;;^DD(.4031,7,1,1,2)
 ;;=K ^DIST(.403,DA(1),40,"C",$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)
 ;;^DD(.4031,7,1,1,3)
 ;;=Programmer only
 ;;^DD(.4031,7,1,1,"%D",0)
 ;;=^^2^2^2930816^
 ;;^DD(.4031,7,1,1,"%D",1,0)
 ;;=This cross reference is a regular index of the page name converted to all
 ;;^DD(.4031,7,1,1,"%D",2,0)
 ;;=upper case characters.
 ;;^DD(.4031,7,1,1,"DT")
 ;;=2930816
 ;;^DD(.4031,7,3)
 ;;=Enter the name of the page, 3-30 characters in length.
 ;;^DD(.4031,7,21,0)
 ;;=^^5^5^2940907^^
 ;;^DD(.4031,7,21,1,0)
 ;;=Like the Page Number, you can use the Page Name to refer to a page in
 ;;^DD(.4031,7,21,2,0)
 ;;=ScreenMan functions and utilities.  ScreenMan displays the Page Name to
 ;;^DD(.4031,7,21,3,0)
 ;;=the user if, during an attempt to file data, ScreenMan finds required
 ;;^DD(.4031,7,21,4,0)
 ;;=fields with null values.  ScreenMan uses the Caption of the field and the
 ;;^DD(.4031,7,21,5,0)
 ;;=Page Name to inform the user of the location of the required field.
 ;;^DD(.4031,7,"DT")
 ;;=2931020
 ;;^DD(.4031,8,0)
 ;;=PARENT FIELD^FX^^1;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>92!($L(X)<5)!'(X?1.E1","1.E1","1.E) X I $D(X) D PFIELD^DDSIT
 ;;^DD(.4031,8,1,0)
 ;;=^.1^^0
 ;;^DD(.4031,8,3)
 ;;=Answer must be 5-92 characters in length.
 ;;^DD(.4031,8,21,0)
 ;;=^^25^25^2940907^
 ;;^DD(.4031,8,21,1,0)
 ;;=This property can be used instead of Subpage Link to link a subpage to a
 ;;^DD(.4031,8,21,2,0)
 ;;=field.
 ;;^DD(.4031,8,21,3,0)
 ;;= 
 ;;^DD(.4031,8,21,4,0)
 ;;=Parent Field has the following format:
 ;;^DD(.4031,8,21,5,0)
 ;;= 
 ;;^DD(.4031,8,21,6,0)
 ;;=       Field id,Block id,Page id
 ;;^DD(.4031,8,21,7,0)
 ;;= 
 ;;^DD(.4031,8,21,8,0)
 ;;=where,
 ;;^DD(.4031,8,21,9,0)
 ;;= 
 ;;^DD(.4031,8,21,10,0)
 ;;=       Field id  =  Field Order number; or
 ;;^DD(.4031,8,21,11,0)
 ;;=                    Caption of the field; or
 ;;^DD(.4031,8,21,12,0)
 ;;=                    Unique Name of the field
 ;;^DD(.4031,8,21,13,0)
 ;;= 
 ;;^DD(.4031,8,21,14,0)
 ;;=       Block id  =  Block Order number; or
 ;;^DD(.4031,8,21,15,0)
 ;;=                    Block Name
 ;;^DD(.4031,8,21,16,0)
 ;;= 
 ;;^DD(.4031,8,21,17,0)
 ;;=       Page id   =  Page Number; or
 ;;^DD(.4031,8,21,18,0)
 ;;=                    Page Name
 ;;^DD(.4031,8,21,19,0)
 ;;= 
 ;;^DD(.4031,8,21,20,0)
 ;;=For example:
 ;;^DD(.4031,8,21,21,0)
 ;;= 
 ;;^DD(.4031,8,21,22,0)
 ;;=       ZZFIELD 1,ZZBLOCK 1,ZZPAGE 1
 ;;^DD(.4031,8,21,23,0)
 ;;= 
 ;;^DD(.4031,8,21,24,0)
 ;;=identifies the field with Caption or Unique Name "ZZFIELD 1," on the block
 ;;^DD(.4031,8,21,25,0)
 ;;=named "ZZBLOCK 1," on the page named "ZZPAGE 1".
 ;;^DD(.4031,8,"DT")
 ;;=2931201
 ;;^DD(.4031,11,0)
 ;;=PRE ACTION^K^^11;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4031,11,3)
 ;;=Enter Standard MUMPS code that will be executed before the user reaches a page.
 ;;^DD(.4031,11,9)
 ;;=@
 ;;^DD(.4031,11,21,0)
 ;;=^^1^1^2940907^^^^
 ;;^DD(.4031,11,21,1,0)
 ;;=This MUMPS code is executed when the user reaches a page.
 ;;^DD(.4031,11,22)
 ;;=
 ;;^DD(.4031,12,0)
 ;;=POST ACTION^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4031,12,3)
 ;;=Enter Standard MUMPS code that will be executed after the user leaves a page.
 ;;^DD(.4031,12,9)
 ;;=@
 ;;^DD(.4031,12,21,0)
 ;;=^^1^1^2940907^^^
 ;;^DD(.4031,12,21,1,0)
 ;;=This MUMPS code is executed when the user leaves the page.
 ;;^DD(.4031,15,0)
 ;;=DESCRIPTION^.403115^^15;0
 ;;^DD(.4031,40,0)
 ;;=BLOCK^.4032IP^^40;0
 ;;^DD(.403115,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(.403115,0,"DT")
 ;;=2910204
 ;;^DD(.403115,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(.403115,0,"UP")
 ;;=.4031
 ;;^DD(.403115,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(.403115,.01,3)
 ;;=Enter text which describes the page.

DINIT295
DINIT295 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT296 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.403115,.01,21,0)
 ;;=^^1^1^2940908^^
 ;;^DD(.403115,.01,21,1,0)
 ;;=Enter text that describes this page.
 ;;^DD(.40315,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(.40315,0,"DT")
 ;;=2910204
 ;;^DD(.40315,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(.40315,0,"UP")
 ;;=.403
 ;;^DD(.40315,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(.40315,.01,3)
 ;;=
 ;;^DD(.40315,.01,21,0)
 ;;=^^1^1^2940908^^^^
 ;;^DD(.40315,.01,21,1,0)
 ;;=Enter text that describes this form.
 ;;^DD(.4032,0)
 ;;=BLOCK SUB-FIELD^^12^12
 ;;^DD(.4032,0,"DT")
 ;;=2940506
 ;;^DD(.4032,0,"ID","WRITE")
 ;;=D EN^DDIOL("(Block Order "_$P(^(0),U,2)_")","","?35")
 ;;^DD(.4032,0,"IX","AC",.4032,1)
 ;;=
 ;;^DD(.4032,0,"IX","B",.4032,.01)
 ;;=
 ;;^DD(.4032,0,"NM","BLOCK")
 ;;=
 ;;^DD(.4032,0,"UP")
 ;;=.4031
 ;;^DD(.4032,.01,0)
 ;;=BLOCK NAME^MP.404X^DIST(.404,^0;1^S:$D(X) DINUM=X
 ;;^DD(.4032,.01,1,0)
 ;;=^.1
 ;;^DD(.4032,.01,1,1,0)
 ;;=.4032^B
 ;;^DD(.4032,.01,1,1,1)
 ;;=S ^DIST(.403,DA(2),40,DA(1),40,"B",$E(X,1,30),DA)=""
 ;;^DD(.4032,.01,1,1,2)
 ;;=K ^DIST(.403,DA(2),40,DA(1),40,"B",$E(X,1,30),DA)
 ;;^DD(.4032,.01,1,2,0)
 ;;=.403^AB
 ;;^DD(.4032,.01,1,2,1)
 ;;=S ^DIST(.403,"AB",$E(X,1,30),DA(2),DA(1),DA)=""
 ;;^DD(.4032,.01,1,2,2)
 ;;=K ^DIST(.403,"AB",$E(X,1,30),DA(2),DA(1),DA)
 ;;^DD(.4032,.01,1,2,"%D",0)
 ;;=^^2^2^2930521^
 ;;^DD(.4032,.01,1,2,"%D",1,0)
 ;;=This cross reference provides an index that can be used to determine
 ;;^DD(.4032,.01,1,2,"%D",2,0)
 ;;=the forms on which a block is used.
 ;;^DD(.4032,.01,1,2,"DT")
 ;;=2930521
 ;;^DD(.4032,.01,21,0)
 ;;=^^1^1^2940908^^^^
 ;;^DD(.4032,.01,21,1,0)
 ;;=Enter the name of the block to be placed on this page of the form.
 ;;^DD(.4032,.01,"DT")
 ;;=2930521
 ;;^DD(.4032,1,0)
 ;;=BLOCK ORDER^RNJ4,1X^^0;2^K:+X'=X!(X>99.9)!(X<1)!(X?.E1"."2N.N)!$D(^DIST(.403,DA(2),40,DA(1),40,"AC",X)) X
 ;;^DD(.4032,1,1,0)
 ;;=^.1
 ;;^DD(.4032,1,1,1,0)
 ;;=.4032^AC
 ;;^DD(.4032,1,1,1,1)
 ;;=S ^DIST(.403,DA(2),40,DA(1),40,"AC",$E(X,1,30),DA)=""
 ;;^DD(.4032,1,1,1,2)
 ;;=K ^DIST(.403,DA(2),40,DA(1),40,"AC",$E(X,1,30),DA)
 ;;^DD(.4032,1,1,1,"%D",0)
 ;;=^^2^2^2910118^^
 ;;^DD(.4032,1,1,1,"%D",1,0)
 ;;=This cross-reference is used to ensure that order numbers are unique for
 ;;^DD(.4032,1,1,1,"%D",2,0)
 ;;=the page.
 ;;^DD(.4032,1,1,1,"DT")
 ;;=2910118
 ;;^DD(.4032,1,3)
 ;;=Enter a number between 1 and 99.9, 1 Decimal Digit, which represents the order in which the block will be processed within the page.  This number must be unique for the page.
 ;;^DD(.4032,1,21,0)
 ;;=^^5^5^2940907^^
 ;;^DD(.4032,1,21,1,0)
 ;;=The Block Order determines the order users traverse fields on a page when
 ;;^DD(.4032,1,21,2,0)
 ;;=they press <PF1><PF4> to go to the next block, or press <RET> to move from
 ;;^DD(.4032,1,21,3,0)
 ;;=the last field on one block to the first field on the next.  When the user
 ;;^DD(.4032,1,21,4,0)
 ;;=first reaches a page, ScreenMan places the user on the block with the
 ;;^DD(.4032,1,21,5,0)
 ;;=lowest Block Order number.
 ;;^DD(.4032,2,0)
 ;;=BLOCK COORDINATE^F^^0;3^K:$L(X)>7!($L(X)<1)!'(X?.N1",".N) X
 ;;^DD(.4032,2,3)
 ;;=Enter the block coordinate relative to the page coordinate.  Answer must be two positive integers separated by a comma (,), as follows:  'Upper left row,Upper left column.'
 ;;^DD(.4032,2,21,0)
 ;;=^^2^2^2940907^^
 ;;^DD(.4032,2,21,1,0)
 ;;=The block coordinate is relative to the page coordinate.  The first row
 ;;^DD(.4032,2,21,2,0)
 ;;=and column on the block have a coordinate of 1,1.
 ;;^DD(.4032,2,"DT")
 ;;=2940908
 ;;^DD(.4032,3,0)
 ;;=TYPE OF BLOCK^S^e:EDIT;d:DISPLAY;^0;4^Q
 ;;^DD(.4032,3,3)
 ;;=
 ;;^DD(.4032,3,21,0)
 ;;=^^7^7^2940907^
 ;;^DD(.4032,3,21,1,0)
 ;;=Enter 'EDIT' if users can navigate to as well as edit fields in this
 ;;^DD(.4032,3,21,2,0)
 ;;=block.  Enter 'DISPLAY' if users cannot edit any of the fields in this
 ;;^DD(.4032,3,21,3,0)
 ;;=block.  User's can navigate to a DISPLAY block only if it contains
 ;;^DD(.4032,3,21,4,0)
 ;;=multiple or word processing fields, in which case, the cursor stops at any
 ;;^DD(.4032,3,21,5,0)
 ;;=of those two kinds of fields so that the user can press <RET> to view or
 ;;^DD(.4032,3,21,6,0)
 ;;=edit the subfields in the multiple or invoke an editor to view the
 ;;^DD(.4032,3,21,7,0)
 ;;=contents of the word processing field.
 ;;^DD(.4032,3,"DT")
 ;;=2940413
 ;;^DD(.4032,4,0)
 ;;=POINTER LINK^FX^^1;1^K:$L(X)>245!($L(X)<1) X I $D(X) D PLINK^DDSIT

DINIT296
DINIT296 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT297 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4032,4,3)
 ;;=Answer must be 1-245 characters in length.
 ;;^DD(.4032,4,21,0)
 ;;=^^9^9^2940907^^
 ;;^DD(.4032,4,21,1,0)
 ;;=If the fields displayed in this block are reached through a relational
 ;;^DD(.4032,4,21,2,0)
 ;;=jump from the primary file of the form, enter the relational expression
 ;;^DD(.4032,4,21,3,0)
 ;;=that describes this jump.  Your frame of reference is the primary file of
 ;;^DD(.4032,4,21,4,0)
 ;;=the form.
 ;;^DD(.4032,4,21,5,0)
 ;;= 
 ;;^DD(.4032,4,21,6,0)
 ;;=For example, if the primary file has a field #999 called TEST that points
 ;;^DD(.4032,4,21,7,0)
 ;;=to the file associated with this block, enter
 ;;^DD(.4032,4,21,8,0)
 ;;= 
 ;;^DD(.4032,4,21,9,0)
 ;;=     999 or TEST
 ;;^DD(.4032,4,"DT")
 ;;=2931201
 ;;^DD(.4032,5,0)
 ;;=REPLICATION^NJ3,0^^2;1^K:+X'=X!(X>999)!(X<2)!(X?.E1"."1N.N) X
 ;;^DD(.4032,5,3)
 ;;=Type a Number between 2 and 999, 0 Decimal Digits
 ;;^DD(.4032,5,21,0)
 ;;=^^3^3^2940907^^
 ;;^DD(.4032,5,21,1,0)
 ;;=If this is a repeating block, enter the number of times the fields
 ;;^DD(.4032,5,21,2,0)
 ;;=defined in this block should be replicated.  If used, this number must
 ;;^DD(.4032,5,21,3,0)
 ;;=be greater than 1.
 ;;^DD(.4032,5,"DT")
 ;;=2940503
 ;;^DD(.4032,6,0)
 ;;=INDEX^F^^2;2^K:$L(X)>63!($L(X)<1) X
 ;;^DD(.4032,6,3)
 ;;=Answer must be 1-63 characters in length.
 ;;^DD(.4032,6,21,0)
 ;;=^^7^7^2941020^
 ;;^DD(.4032,6,21,1,0)
 ;;=Enter the name of the cross reference that should be used to pick up the
 ;;^DD(.4032,6,21,2,0)
 ;;=subentries in the multiple.  ScreenMan will initially display the
 ;;^DD(.4032,6,21,3,0)
 ;;=subentries to the user sorted in the order defined by this index.  The
 ;;^DD(.4032,6,21,4,0)
 ;;=default INDEX is B.
 ;;^DD(.4032,6,21,5,0)
 ;;= 
 ;;^DD(.4032,6,21,6,0)
 ;;=If the multiple has no index, or you wish to display the subentries
 ;;^DD(.4032,6,21,7,0)
 ;;=in record number order, enter !IEN.
 ;;^DD(.4032,6,"DT")
 ;;=2940503
 ;;^DD(.4032,7,0)
 ;;=INITIAL POSITION^S^f:FIRST;l:LAST;n:NEW;^2;3^Q
 ;;^DD(.4032,7,21,0)
 ;;=^^5^5^2940908^
 ;;^DD(.4032,7,21,1,0)
 ;;=This is the position in the list where the cursor should initially rest
 ;;^DD(.4032,7,21,2,0)
 ;;=when the user first navigates to the repeating block.  Possible values are
 ;;^DD(.4032,7,21,3,0)
 ;;=FIRST, LAST, and NEW, where NEW indicates that the cursor should initially
 ;;^DD(.4032,7,21,4,0)
 ;;=rest on the blank line at the end of the list.  The default INITIAL
 ;;^DD(.4032,7,21,5,0)
 ;;=POSITION is FIRST.
 ;;^DD(.4032,7,"DT")
 ;;=2940503
 ;;^DD(.4032,8,0)
 ;;=DISALLOW LAYGO^S^0:NO;1:YES;^2;4^Q
 ;;^DD(.4032,8,21,0)
 ;;=^^3^3^2940907^^
 ;;^DD(.4032,8,21,1,0)
 ;;=If set to YES, this prohibits the user from entering new subentries into
 ;;^DD(.4032,8,21,2,0)
 ;;=the multiple.  If null or set to NO, the setting in the data dictionary
 ;;^DD(.4032,8,21,3,0)
 ;;=determines whether LAYGO is allowed.
 ;;^DD(.4032,8,"DT")
 ;;=2940505
 ;;^DD(.4032,9,0)
 ;;=FIELD FOR SELECTION^F^^2;5^K:$L(X)>30!($L(X)<1) X
 ;;^DD(.4032,9,3)
 ;;=Answer must be 1-30 characters in length.
 ;;^DD(.4032,9,21,0)
 ;;=^^5^5^2940907^^
 ;;^DD(.4032,9,21,1,0)
 ;;=This is the field order of the field that defines the column position of
 ;;^DD(.4032,9,21,2,0)
 ;;=the blank line at the end of the list.  The default is the first editable
 ;;^DD(.4032,9,21,3,0)
 ;;=field in the block.  This is also the field before which ScreenMan prints
 ;;^DD(.4032,9,21,4,0)
 ;;=the plus sign (+) to indicate there are more entries above or below the
 ;;^DD(.4032,9,21,5,0)
 ;;=displayed list.
 ;;^DD(.4032,9,"DT")
 ;;=2940506
 ;;^DD(.4032,11,0)
 ;;=PRE ACTION^K^^11;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4032,11,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.4032,11,9)
 ;;=@
 ;;^DD(.4032,11,21,0)
 ;;=^^5^5^2940907^
 ;;^DD(.4032,11,21,1,0)
 ;;=Enter MUMPS code that is executed whenever the user reaches this block.
 ;;^DD(.4032,11,21,2,0)
 ;;= 
 ;;^DD(.4032,11,21,3,0)
 ;;=This pre-action is a characteristic of the block only as it is used on
 ;;^DD(.4032,11,21,4,0)
 ;;=this form.  If you place this block on another form, you can define a
 ;;^DD(.4032,11,21,5,0)
 ;;=different pre-action.
 ;;^DD(.4032,11,"DT")
 ;;=2930610
 ;;^DD(.4032,12,0)
 ;;=POST ACTION^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4032,12,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.4032,12,9)
 ;;=@
 ;;^DD(.4032,12,21,0)
 ;;=^^5^5^2940907^
 ;;^DD(.4032,12,21,1,0)
 ;;=Enter MUMPS code that is executed whenever the user leaves this block.

DINIT297
DINIT297 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT298 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4032,12,21,2,0)
 ;;= 
 ;;^DD(.4032,12,21,3,0)
 ;;=This post-action is a characteristic of the block only as it is used on
 ;;^DD(.4032,12,21,4,0)
 ;;=this form.  If you place this block on another form, you can define a
 ;;^DD(.4032,12,21,5,0)
 ;;=different post-action.
 ;;^DD(.4032,12,"DT")
 ;;=2930610

DINIT298
DINIT298 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT299 S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DIC("B","BLOCK",.404)
 ;;=
 ;;^DIC(.404,"%D",0)
 ;;=^^2^2^2940914^
 ;;^DIC(.404,"%D",1,0)
 ;;=This file stores ScreenMan blocks, which are used to build forms in the
 ;;^DIC(.404,"%D",2,0)
 ;;=Form file.
 ;;^DD(.404,0)
 ;;=FIELD^^40^7
 ;;^DD(.404,0,"DT")
 ;;=2940625
 ;;^DD(.404,0,"IX","B",.404,.01)
 ;;=
 ;;^DD(.404,0,"NM","BLOCK")
 ;;=
 ;;^DD(.404,0,"PT",.4031,1)
 ;;=
 ;;^DD(.404,0,"PT",.4032,.01)
 ;;=
 ;;^DD(.404,.01,0)
 ;;=NAME^RFX^^0;1^K:$L(X)>30!($L(X)<3)!(X?1P.E)!(X=+$P(X,"E")) X I $D(X),$S($D(DDS)&$G(DA):$P($G(^DIST(.404,DA,0)),U)'=X,1:1),$D(^DIST(.404,"B",X)) K X
 ;;^DD(.404,.01,1,0)
 ;;=^.1
 ;;^DD(.404,.01,1,1,0)
 ;;=.404^B
 ;;^DD(.404,.01,1,1,1)
 ;;=S ^DIST(.404,"B",$E(X,1,30),DA)=""
 ;;^DD(.404,.01,1,1,2)
 ;;=K ^DIST(.404,"B",$E(X,1,30),DA)
 ;;^DD(.404,.01,1,1,"DT")
 ;;=2900912
 ;;^DD(.404,.01,3)
 ;;=Answer must be 3-30 characters in length.
 ;;^DD(.404,.01,21,0)
 ;;=^^2^2^2940907^^
 ;;^DD(.404,.01,21,1,0)
 ;;=Enter the name of the block, 3-30 characters in length.  The block name
 ;;^DD(.404,.01,21,2,0)
 ;;=must be unique and cannot be numeric or start with punctuation.
 ;;^DD(.404,.01,"DEL",1,0)
 ;;=I '$D(DDSDEL) D EN^DDIOL($C(7)_"You must use the FileMan options to delete blocks.") I 1
 ;;^DD(.404,.01,"DT")
 ;;=2931020
 ;;^DD(.404,1,0)
 ;;=DATA DICTIONARY NUMBER^FX^^0;2^K:X'=+$P(X,"E")!(X<2)!($L(X)>16)!'$D(^DD(X)) X
 ;;^DD(.404,1,3)
 ;;=Answer must be 1-16 characters in length.
 ;;^DD(.404,1,21,0)
 ;;=^^3^3^2940907^
 ;;^DD(.404,1,21,1,0)
 ;;=Enter the data dictionary number of the file or subfile that contains the
 ;;^DD(.404,1,21,2,0)
 ;;=fields that are placed on this block.  A block can contain fields from
 ;;^DD(.404,1,21,3,0)
 ;;=only one file or subfile.
 ;;^DD(.404,1,"DT")
 ;;=2930406
 ;;^DD(.404,2,0)
 ;;=DISABLE NAVIGATION^S^0:NO;1:YES;2:OUTOK;^0;3^Q
 ;;^DD(.404,2,3)
 ;;=
 ;;^DD(.404,2,21,0)
 ;;=^^8^8^2940907^^
 ;;^DD(.404,2,21,1,0)
 ;;=Enter 'YES' if navigation within the block should be disabled.  When
 ;;^DD(.404,2,21,2,0)
 ;;=navigation is disabled, user cannot ^-jump to other fields, they cannot
 ;;^DD(.404,2,21,3,0)
 ;;=^-jump to the Command Line, and the <Up>, <Down>, <Tab>, and <PF4> keys
 ;;^DD(.404,2,21,4,0)
 ;;=traverse the fields in the same order as the <RET> key -- that is, in the
 ;;^DD(.404,2,21,5,0)
 ;;=order established by the Field Order property of the fields.
 ;;^DD(.404,2,21,6,0)
 ;;= 
 ;;^DD(.404,2,21,7,0)
 ;;=Enter 'OUTOK' to disable navigation, but allow the user to ^-jump to the
 ;;^DD(.404,2,21,8,0)
 ;;=Command Line.
 ;;^DD(.404,11,0)
 ;;=PRE ACTION^K^^11;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.404,11,3)
 ;;=Enter standard MUMPS code that will be executed when the user navigates to the block.
 ;;^DD(.404,11,9)
 ;;=@
 ;;^DD(.404,11,21,0)
 ;;=^^6^6^2940907^^
 ;;^DD(.404,11,21,1,0)
 ;;=This is MUMPS code that is executed when the user navigates to the
 ;;^DD(.404,11,21,2,0)
 ;;=block.
 ;;^DD(.404,11,21,3,0)
 ;;= 
 ;;^DD(.404,11,21,4,0)
 ;;=This pre-action is part of the block definition itself, so if this
 ;;^DD(.404,11,21,5,0)
 ;;=block is used on another page or another form, the pre-action still
 ;;^DD(.404,11,21,6,0)
 ;;=applies.
 ;;^DD(.404,12,0)
 ;;=POST ACTION^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.404,12,3)
 ;;=Enter standard MUMPS that will be executed when the user leaves the block.
 ;;^DD(.404,12,9)
 ;;=@
 ;;^DD(.404,12,21,0)
 ;;=^^5^5^2940907^^
 ;;^DD(.404,12,21,1,0)
 ;;=This is MUMPS code that is executed when the user leaves the block.
 ;;^DD(.404,12,21,2,0)
 ;;= 
 ;;^DD(.404,12,21,3,0)
 ;;=This post-action is part of the block definition itself, so if the
 ;;^DD(.404,12,21,4,0)
 ;;=block is used on another page or on another form, the post-action still
 ;;^DD(.404,12,21,5,0)
 ;;=applies.
 ;;^DD(.404,15,0)
 ;;=DESCRIPTION^.40415^^15;0
 ;;^DD(.404,40,0)
 ;;=FIELD^.4044I^^40;0
 ;;^DD(.404,40,"DT")
 ;;=2931029
 ;;^DD(.40415,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(.40415,0,"DT")
 ;;=2910204
 ;;^DD(.40415,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(.40415,0,"UP")
 ;;=.404
 ;;^DD(.40415,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(.40415,.01,3)
 ;;=
 ;;^DD(.40415,.01,21,0)
 ;;=^^1^1^2940908^^^
 ;;^DD(.40415,.01,21,1,0)
 ;;=Enter text that describes this block.
 ;;^DD(.4044,0)
 ;;=FIELD SUB-FIELD^^30^32
 ;;^DD(.4044,0,"DT")
 ;;=2940625
 ;;^DD(.4044,0,"ID","WRITE")
 ;;=D EN^DDIOL($S($P(^(0),U,2)?1"Select "1.E:$E($P(^(0),U,2),8,999),1:$S($P(^(0),U,2)="!M":$G(^(.1)),1:$P(^(0),U,2)))_$S($P(^(0),U,4)]"":"  ("_$P(^(0),U,4)_")",1:""),"","?9")

DINIT299
DINIT299 ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29A S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,0,"ID","WRITE1")
 ;;=D EN^DDIOL($S($P($G(^(7)),U,2):"  (Sub Page Link defined)",1:"")_$S($G(^(1)):"   (Field #"_^(1)_")",1:"")_$S($P(^(0),U,5)]"":"  ("_$P(^(0),U,5)_")",1:""),"","?0")
 ;;^DD(.4044,0,"IX","B",.4044,.01)
 ;;=
 ;;^DD(.4044,0,"IX","C",.4044,1)
 ;;=
 ;;^DD(.4044,0,"IX","D",.4044,3.1)
 ;;=
 ;;^DD(.4044,0,"NM","FIELD")
 ;;=
 ;;^DD(.4044,0,"UP")
 ;;=.404
 ;;^DD(.4044,.01,0)
 ;;=FIELD ORDER^MNJ4,1X^^0;1^K:X'=+$P(X,"E")!(X>99.9)!(X<0)!(X?.E1"."2N.N) X I $D(X),$D(^DIST(.404,DA(1),40,"B",X)) K X
 ;;^DD(.4044,.01,1,0)
 ;;=^.1
 ;;^DD(.4044,.01,1,1,0)
 ;;=.4044^B
 ;;^DD(.4044,.01,1,1,1)
 ;;=S ^DIST(.404,DA(1),40,"B",$E(X,1,30),DA)=""
 ;;^DD(.4044,.01,1,1,2)
 ;;=K ^DIST(.404,DA(1),40,"B",$E(X,1,30),DA)
 ;;^DD(.4044,.01,3)
 ;;=Enter a unique number between 0 and 99.9, inclusive, which represents the order in which the fields will be edited.
 ;;^DD(.4044,.01,21,0)
 ;;=^^2^2^2940907^
 ;;^DD(.4044,.01,21,1,0)
 ;;=The Field Order number determines the order in which users traverse the
 ;;^DD(.4044,.01,21,2,0)
 ;;=fields in the block as they press <RET>.
 ;;^DD(.4044,1,0)
 ;;=CAPTION^FX^^0;2^K:$L(X)>80!($L(X)<1) X S:$E($G(X))="!"&($G(X)'="!M") X=$$FUNC^DDSCAP(X)
 ;;^DD(.4044,1,1,0)
 ;;=^.1^^-1
 ;;^DD(.4044,1,1,2,0)
 ;;=.4044^C^MUMPS
 ;;^DD(.4044,1,1,2,1)
 ;;=S:X'="!M" ^DIST(.404,DA(1),40,"C",$TR($E($S(X?1"Select "1.E:$P(X,"Select ",2,99),1:X),1,63),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)=""
 ;;^DD(.4044,1,1,2,2)
 ;;=K:X'="!M" ^DIST(.404,DA(1),40,"C",$TR($E($S(X?1"Select "1.E:$P(X,"Select ",2,99),1:X),1,63),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)
 ;;^DD(.4044,1,1,2,3)
 ;;=Programmer only
 ;;^DD(.4044,1,1,2,"%D",0)
 ;;=^^2^2^2931029^^^^
 ;;^DD(.4044,1,1,2,"%D",1,0)
 ;;=This cross referenced is used to allow selection of fields by caption name
 ;;^DD(.4044,1,1,2,"%D",2,0)
 ;;=as well as by order number when entering new fields in the block.
 ;;^DD(.4044,1,1,2,"DT")
 ;;=2920214
 ;;^DD(.4044,1,3)
 ;;=Answer must be 1-80 characters in length.
 ;;^DD(.4044,1,21,0)
 ;;=^^6^6^2940907^
 ;;^DD(.4044,1,21,1,0)
 ;;=A caption is uneditable text that appears on the screen.  Captions of
 ;;^DD(.4044,1,21,2,0)
 ;;=data dictionary, form-only, and computed fields serve to identify for
 ;;^DD(.4044,1,21,3,0)
 ;;=the user the data portion of the fields.  Captions for these types of
 ;;^DD(.4044,1,21,4,0)
 ;;=fields are automatically followed by a colon, unless the Suppress Colon
 ;;^DD(.4044,1,21,5,0)
 ;;=After Caption property is set to 'YES.'  A field with an Executable
 ;;^DD(.4044,1,21,6,0)
 ;;=Caption must have '!M' as a Caption.
 ;;^DD(.4044,1,"DT")
 ;;=2940629
 ;;^DD(.4044,1.1,0)
 ;;=EXECUTABLE CAPTION^K^^.1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,1.1,3)
 ;;=Enter standard MUMPS code that sets the variable Y.
 ;;^DD(.4044,1.1,9)
 ;;=@
 ;;^DD(.4044,1.1,21,0)
 ;;=^^3^3^2940907^^
 ;;^DD(.4044,1.1,21,1,0)
 ;;=Enter MUMPS code that sets the variable Y equal to the caption you
 ;;^DD(.4044,1.1,21,2,0)
 ;;=want displayed.  This code is executed and the caption evaluated whenever
 ;;^DD(.4044,1.1,21,3,0)
 ;;=the page on which this caption is located is painted.
 ;;^DD(.4044,1.1,"DT")
 ;;=2920218
 ;;^DD(.4044,2,0)
 ;;=FIELD TYPE^*S^0:UNKNOWN;1:CAPTION ONLY;2:FORM ONLY;3:DATA DICTIONARY FIELD;4:COMPUTED;^0;3^Q
 ;;^DD(.4044,2,1,0)
 ;;=^.1^^0
 ;;^DD(.4044,2,3)
 ;;=
 ;;^DD(.4044,2,12)
 ;;=Enter the field type.
 ;;^DD(.4044,2,12.1)
 ;;=S DIC("S")="I Y"
 ;;^DD(.4044,2,21,0)
 ;;=^^11^11^2940907^
 ;;^DD(.4044,2,21,1,0)
 ;;=Enter the field type.
 ;;^DD(.4044,2,21,2,0)
 ;;= 
 ;;^DD(.4044,2,21,3,0)
 ;;=CAPTION ONLY fields are for displaying text on the screen.
 ;;^DD(.4044,2,21,4,0)
 ;;= 
 ;;^DD(.4044,2,21,5,0)
 ;;=FORM ONLY fields are fields defined only on the form and are not tied to a
 ;;^DD(.4044,2,21,6,0)
 ;;=field in a FileMan file.
 ;;^DD(.4044,2,21,7,0)
 ;;= 
 ;;^DD(.4044,2,21,8,0)
 ;;=DATA DICTIONARY fields are fields from a FileMan file.
 ;;^DD(.4044,2,21,9,0)
 ;;= 
 ;;^DD(.4044,2,21,10,0)
 ;;=COMPUTED fields, like form-only fields, are fields that are defined only
 ;;^DD(.4044,2,21,11,0)
 ;;=on the form.  Associated with a COMPUTED field is a computed expression.
 ;;^DD(.4044,2,"DT")
 ;;=2940907
 ;;^DD(.4044,3,0)
 ;;=DISPLAY GROUP^F^^0;4^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<1) X
 ;;^DD(.4044,3,3)
 ;;=Enter text, 1-20 characters in length, which represents the group to which this field belongs.

DINIT29A
DINIT29A ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29B S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,3,21,0)
 ;;=^^10^10^2940907^
 ;;^DD(.4044,3,21,1,0)
 ;;=Display group helps users resolve ambiguity when they attempt to ^-jump to
 ;;^DD(.4044,3,21,2,0)
 ;;=a field that has a caption that is not unique.  If more than one field has
 ;;^DD(.4044,3,21,3,0)
 ;;=the same caption, when users try to ^-jump to a field with that caption,
 ;;^DD(.4044,3,21,4,0)
 ;;=they are presented with a list of fields to choose from.  The text in the
 ;;^DD(.4044,3,21,5,0)
 ;;=Display Group property is displayed in parentheses after the caption to
 ;;^DD(.4044,3,21,6,0)
 ;;=help the user identify the correct field.
 ;;^DD(.4044,3,21,7,0)
 ;;= 
 ;;^DD(.4044,3,21,8,0)
 ;;=For example, if two fields have the caption 'NAME:', but one of those
 ;;^DD(.4044,3,21,9,0)
 ;;=fields has a Display Group 'Next of Kin', when users enter ^NAME, they
 ;;^DD(.4044,3,21,10,0)
 ;;=will be asked to choose between 'NAME' and 'NAME (Next of Kin)'.
 ;;^DD(.4044,3.1,0)
 ;;=UNIQUE NAME^FX^^0;5^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>50!($L(X)<3)!$D(^DIST(.404,DA(1),40,"D",X)) X
 ;;^DD(.4044,3.1,1,0)
 ;;=^.1
 ;;^DD(.4044,3.1,1,1,0)
 ;;=.4044^D^MUMPS
 ;;^DD(.4044,3.1,1,1,1)
 ;;=S ^DIST(.404,DA(1),40,"D",$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)=""
 ;;^DD(.4044,3.1,1,1,2)
 ;;=K ^DIST(.404,DA(1),40,"D",$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),DA)
 ;;^DD(.4044,3.1,1,1,3)
 ;;=Programmer only
 ;;^DD(.4044,3.1,1,1,"%D",0)
 ;;=^^1^1^2930816^
 ;;^DD(.4044,3.1,1,1,"%D",1,0)
 ;;=This is a regular index of the Unique Name converted to uppercase.
 ;;^DD(.4044,3.1,1,1,"DT")
 ;;=2930816
 ;;^DD(.4044,3.1,3)
 ;;=Answer must be 1-50 characters in length.
 ;;^DD(.4044,3.1,21,0)
 ;;=^^5^5^2940907^
 ;;^DD(.4044,3.1,21,1,0)
 ;;=This is the unique name of the element on the block.  No two elements on
 ;;^DD(.4044,3.1,21,2,0)
 ;;=the block can have the same Unique Name.  Unique Names are never seen by
 ;;^DD(.4044,3.1,21,3,0)
 ;;=the user.  You can refer to an element on a block by its Unique Name in
 ;;^DD(.4044,3.1,21,4,0)
 ;;=some of the ScreenMan utilities such as PUT^DDSVAL and $$GET^DDSVAL, and
 ;;^DD(.4044,3.1,21,5,0)
 ;;=in the computed expressions of computed fields.
 ;;^DD(.4044,3.1,"DT")
 ;;=2930816
 ;;^DD(.4044,4,0)
 ;;=FIELD^FX^^1;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>245!($L(X)<1) X I $D(X),$D(DDGFDD) D IXF^DDS0
 ;;^DD(.4044,4,1,0)
 ;;=^.1^^0
 ;;^DD(.4044,4,3)
 ;;=Answer must be 1-245 characters in length.
 ;;^DD(.4044,4,4)
 ;;=I $D(DDGFDD) N D0,DA,DIC,D,DZ S DIC="^DD("_DDGFDD_",",DIC(0)="",D="B" S:$G(X)="??" DZ=X D DQ^DICQ
 ;;^DD(.4044,4,21,0)
 ;;=^^2^2^2940907^
 ;;^DD(.4044,4,21,1,0)
 ;;=Enter the number or name of a field in the file defined by the data
 ;;^DD(.4044,4,21,2,0)
 ;;=dictionary number for this block.
 ;;^DD(.4044,4,"DT")
 ;;=2940823
 ;;^DD(.4044,4.1,0)
 ;;=DATA COORDINATE^F^^2;1^K:$L(X)>7!($L(X)<1)!'(X?.N1",".N) X
 ;;^DD(.4044,4.1,3)
 ;;=Enter the field coordinate relative to the block.  Answer must be two positive integers separated by a comma (,), as follows:  'Row,Column'.
 ;;^DD(.4044,4.1,21,0)
 ;;=^^2^2^2940907^
 ;;^DD(.4044,4.1,21,1,0)
 ;;=Data coordinate is relative to the position of the block.  The top left
 ;;^DD(.4044,4.1,21,2,0)
 ;;=corner of the block has a coordinate of 1,1.
 ;;^DD(.4044,4.1,"DT")
 ;;=2940908
 ;;^DD(.4044,4.2,0)
 ;;=DATA LENGTH^NJ3,0^^2;2^K:+X'=X!(X>245)!(X<1)!(X?.E1"."1N.N) X
 ;;^DD(.4044,4.2,3)
 ;;=Enter a Number between 1 and 245, inclusive, which represents the maximum length of the data to be displayed on the screen.
 ;;^DD(.4044,4.2,21,0)
 ;;=^^4^4^2940907^^
 ;;^DD(.4044,4.2,21,1,0)
 ;;=The data length defines the size of the editing window.  The editing
 ;;^DD(.4044,4.2,21,2,0)
 ;;=window is a single line and must not extend into or beyond the rightmost
 ;;^DD(.4044,4.2,21,3,0)
 ;;=column on the screen.  On an 80 column screen, the editing window
 ;;^DD(.4044,4.2,21,4,0)
 ;;=must not extend beyond column 79.
 ;;^DD(.4044,5.1,0)
 ;;=CAPTION COORDINATE^F^^2;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>7!($L(X)<1)!'(X?.N1",".N) X
 ;;^DD(.4044,5.1,1,0)
 ;;=^.1^^0
 ;;^DD(.4044,5.1,3)
 ;;=Enter the caption coordinate relative to the block.  Answer must be two positive integers separated by a comma (,), as follows:  'Row,Column'.
 ;;^DD(.4044,5.1,21,0)
 ;;=^^2^2^2940907^^
 ;;^DD(.4044,5.1,21,1,0)
 ;;=Caption coordinate is relative to the position of the block.  The

DINIT29B
DINIT29B ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29C S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,5.1,21,2,0)
 ;;=top left corner of the block has coordinate 1,1.
 ;;^DD(.4044,5.1,"DT")
 ;;=2940908
 ;;^DD(.4044,5.2,0)
 ;;=SUPPRESS COLON AFTER CAPTION?^S^0:NO;1:YES;^2;4^Q
 ;;^DD(.4044,5.2,1,0)
 ;;=^.1^^0
 ;;^DD(.4044,5.2,3)
 ;;=
 ;;^DD(.4044,5.2,21,0)
 ;;=^^2^2^2940907^^
 ;;^DD(.4044,5.2,21,1,0)
 ;;=Enter 'YES' to suppress the display of a colon and space after the
 ;;^DD(.4044,5.2,21,2,0)
 ;;=caption.
 ;;^DD(.4044,5.2,"DT")
 ;;=2940629
 ;;^DD(.4044,6,0)
 ;;=DEFAULT^F^^3;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>245!($L(X)<1) X
 ;;^DD(.4044,6,3)
 ;;=Answer must be 1-245 characters in length.
 ;;^DD(.4044,6,21,0)
 ;;=^^8^8^2940907^
 ;;^DD(.4044,6,21,1,0)
 ;;=Enter the default you want displayed when the user first loads the page
 ;;^DD(.4044,6,21,2,0)
 ;;=on which this field is located, and the field's value is originally null.
 ;;^DD(.4044,6,21,3,0)
 ;;=Since ScreenMan validates the default, it must be valid, unambiguous, and
 ;;^DD(.4044,6,21,4,0)
 ;;=in external form; otherwise, it is not used.
 ;;^DD(.4044,6,21,5,0)
 ;;= 
 ;;^DD(.4044,6,21,6,0)
 ;;=If you want to create an executable default, i.e., a default whose value
 ;;^DD(.4044,6,21,7,0)
 ;;=is determined at run time when the page is first loaded, the value of
 ;;^DD(.4044,6,21,8,0)
 ;;=this field must be "!M".
 ;;^DD(.4044,6,"DT")
 ;;=2920218
 ;;^DD(.4044,6.01,0)
 ;;=EXECUTABLE DEFAULT^K^^3.1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,6.01,3)
 ;;=Enter standard MUMPS code that sets the variable Y.
 ;;^DD(.4044,6.01,9)
 ;;=@
 ;;^DD(.4044,6.01,21,0)
 ;;=^^4^4^2940907^
 ;;^DD(.4044,6.01,21,1,0)
 ;;=Enter MUMPS code that sets the variable Y equal to the default you want
 ;;^DD(.4044,6.01,21,2,0)
 ;;=displayed when the page is first loaded and the data value on file is
 ;;^DD(.4044,6.01,21,3,0)
 ;;=null.  Y must be set to a valid, unambiguous user response; otherwise, it
 ;;^DD(.4044,6.01,21,4,0)
 ;;=is ignored.
 ;;^DD(.4044,6.01,"DT")
 ;;=2920218
 ;;^DD(.4044,6.1,0)
 ;;=REQUIRED^S^0:NO;1:YES;^4;1^Q
 ;;^DD(.4044,6.1,3)
 ;;=
 ;;^DD(.4044,6.1,21,0)
 ;;=^^5^5^2940907^
 ;;^DD(.4044,6.1,21,1,0)
 ;;=Whenever the user attempts a Save, ScreenMan checks all required fields
 ;;^DD(.4044,6.1,21,2,0)
 ;;=on all pages accessed during the editing session, as well as all pages
 ;;^DD(.4044,6.1,21,3,0)
 ;;=linked to the first page via the Next and Previous Page links.  If any of
 ;;^DD(.4044,6.1,21,4,0)
 ;;=the required fields have null values, no Save occurs.  You need not make a
 ;;^DD(.4044,6.1,21,5,0)
 ;;=field required that is already required by its data definition.
 ;;^DD(.4044,6.2,0)
 ;;=DUPLICATE^S^0:NO;1:YES;^4;2^Q
 ;;^DD(.4044,6.2,3)
 ;;=Enter 'YES' if the field value from the previous record can be duplicated with the 'spacebar-return' feature.
 ;;^DD(.4044,6.2,21,0)
 ;;=^^1^1^2940629^
 ;;^DD(.4044,6.2,21,1,0)
 ;;=This field is not currently being used.
 ;;^DD(.4044,6.3,0)
 ;;=RIGHT JUSTIFY^S^0:NO;1:YES;^4;3^Q
 ;;^DD(.4044,6.3,21,0)
 ;;=^^2^2^2940907^
 ;;^DD(.4044,6.3,21,1,0)
 ;;=Enter 'YES' if the data for this field should be displayed right-justified
 ;;^DD(.4044,6.3,21,2,0)
 ;;=in the editing window.
 ;;^DD(.4044,6.3,"DT")
 ;;=2940625
 ;;^DD(.4044,6.4,0)
 ;;=DISABLE EDITING^S^0:NO;1:YES;2:REACHABLE;^4;4^Q
 ;;^DD(.4044,6.4,3)
 ;;=
 ;;^DD(.4044,6.4,21,0)
 ;;=^^3^3^2940907^^^
 ;;^DD(.4044,6.4,21,1,0)
 ;;=Enter 'YES' to disable editing and to prevent the user from navigating
 ;;^DD(.4044,6.4,21,2,0)
 ;;=to the field.  Enter 'REACHABLE' to disable editing, but allow the user to
 ;;^DD(.4044,6.4,21,3,0)
 ;;=navigate to the field.
 ;;^DD(.4044,6.4,"DT")
 ;;=2940625
 ;;^DD(.4044,6.5,0)
 ;;=DISALLOW LAYGO^S^0:NO;1:YES;^4;5^Q
 ;;^DD(.4044,6.5,3)
 ;;=
 ;;^DD(.4044,6.5,21,0)
 ;;=^^2^2^2931020^
 ;;^DD(.4044,6.5,21,1,0)
 ;;=Enter 'YES' to prohibit the user from adding new subentries into this
 ;;^DD(.4044,6.5,21,2,0)
 ;;=multiple.  This question only pertains to multiple-valued fields.
 ;;^DD(.4044,8,0)
 ;;=SUB PAGE LINK^NJ5,1^^7;2^K:+X'=X!(X>999.9)!(X<1)!(X?.E1"."2N.N) X
 ;;^DD(.4044,8,3)
 ;;=Enter the Page Number of the page to open up when the user presses <Return> at this field.  Type a Number between 1 and 999.9, 1 Decimal Digit.
 ;;^DD(.4044,8,21,0)
 ;;=^^7^7^2940907^
 ;;^DD(.4044,8,21,1,0)
 ;;=If you wish to take users to a pop-up page when they press <RET> at
 ;;^DD(.4044,8,21,2,0)
 ;;=this field, enter the Page Number of that page.  When users exit that

DINIT29C
DINIT29C ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29D S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,8,21,3,0)
 ;;=pop-up page, ScreenMan will automatically take them to the field following
 ;;^DD(.4044,8,21,4,0)
 ;;=this field.
 ;;^DD(.4044,8,21,5,0)
 ;;= 
 ;;^DD(.4044,8,21,6,0)
 ;;=You can also use the Parent Field property of the pop-up page to link a
 ;;^DD(.4044,8,21,7,0)
 ;;=field to the pop-up page.
 ;;^DD(.4044,10,0)
 ;;=BRANCHING LOGIC^K^^10;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,10,3)
 ;;=Enter Standard MUMPS code, 1-245 characters in length.
 ;;^DD(.4044,10,9)
 ;;=@
 ;;^DD(.4044,10,21,0)
 ;;=^^18^18^2940907^
 ;;^DD(.4044,10,21,1,0)
 ;;=This MUMPS code is executed whenever the user presses <RET> at the
 ;;^DD(.4044,10,21,2,0)
 ;;=field.  Here you can set DDSBR equal to the field, block, and page,
 ;;^DD(.4044,10,21,3,0)
 ;;=separated by up-arrow delimiters, of the field to which you wish to take
 ;;^DD(.4044,10,21,4,0)
 ;;=users when they press <RET>.  For example,
 ;;^DD(.4044,10,21,5,0)
 ;;= 
 ;;^DD(.4044,10,21,6,0)
 ;;=     S:X="Y" DDSBR="TEST FIELD 1^TEST BLOCK 1^TEST PAGE 2"
 ;;^DD(.4044,10,21,7,0)
 ;;= 
 ;;^DD(.4044,10,21,8,0)
 ;;=would take the user to the field with unique name or caption "TEST FIELD
 ;;^DD(.4044,10,21,9,0)
 ;;=1" on the block named "TEST BLOCK 1" on a page named "TEST PAGE 2".
 ;;^DD(.4044,10,21,10,0)
 ;;= 
 ;;^DD(.4044,10,21,11,0)
 ;;=Alternatively, if you wish to take users to another page when they press
 ;;^DD(.4044,10,21,12,0)
 ;;=<RET> at this field, and then when they close that page, automatically
 ;;^DD(.4044,10,21,13,0)
 ;;=take them to the field immediately following this field, you can set
 ;;^DD(.4044,10,21,14,0)
 ;;=DDSSTACK equal to the page name or number of that page.
 ;;^DD(.4044,10,21,15,0)
 ;;= 
 ;;^DD(.4044,10,21,16,0)
 ;;=The variable X contains the current internal value of the field, DDSEXT
 ;;^DD(.4044,10,21,17,0)
 ;;=contains the current external value of the field, and DDSOLD contains the
 ;;^DD(.4044,10,21,18,0)
 ;;=previous internal value of the field.
 ;;^DD(.4044,11,0)
 ;;=PRE ACTION^K^^11;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,11,3)
 ;;=Enter standard MUMPS code that will be executed when the user navigates to this field.
 ;;^DD(.4044,11,9)
 ;;=@
 ;;^DD(.4044,11,21,0)
 ;;=^^2^2^2940629^
 ;;^DD(.4044,11,21,1,0)
 ;;=This MUMPS code is executed when the user reaches the field.  The variable
 ;;^DD(.4044,11,21,2,0)
 ;;=X contains the current value of the field.
 ;;^DD(.4044,12,0)
 ;;=POST ACTION^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,12,3)
 ;;=Enter standard MUMPS code that will be executed when the user leaves this field.
 ;;^DD(.4044,12,9)
 ;;=@
 ;;^DD(.4044,12,21,0)
 ;;=^^5^5^2940629^
 ;;^DD(.4044,12,21,1,0)
 ;;=This MUMPS code is executed when the user leaves the field.
 ;;^DD(.4044,12,21,2,0)
 ;;= 
 ;;^DD(.4044,12,21,3,0)
 ;;=The variable X contains the current internal value of the field, DDSEXT
 ;;^DD(.4044,12,21,4,0)
 ;;=contains the current external value of the field, and DDSOLD contains
 ;;^DD(.4044,12,21,5,0)
 ;;=the previous internal value of the field.
 ;;^DD(.4044,13,0)
 ;;=POST ACTION ON CHANGE^K^^13;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,13,3)
 ;;=Enter standard MUMPS code that will be executed when the user changes the value of this field.
 ;;^DD(.4044,13,9)
 ;;=@
 ;;^DD(.4044,13,21,0)
 ;;=^^4^4^2940629^
 ;;^DD(.4044,13,21,1,0)
 ;;=This MUMPS code is executed only if the user changed the value of the
 ;;^DD(.4044,13,21,2,0)
 ;;=field.  The variables X and DDSEXT contain the new internal and external
 ;;^DD(.4044,13,21,3,0)
 ;;=values of the field, and DDSOLD contains the original internal value of
 ;;^DD(.4044,13,21,4,0)
 ;;=the field.
 ;;^DD(.4044,13,"DT")
 ;;=2931029
 ;;^DD(.4044,14,0)
 ;;=DATA VALIDATION^K^^14;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,14,3)
 ;;=This is Standard MUMPS code.
 ;;^DD(.4044,14,9)
 ;;=@
 ;;^DD(.4044,14,21,0)
 ;;=^^5^5^2940907^
 ;;^DD(.4044,14,21,1,0)
 ;;=Enter MUMPS code that will be executed after the user enters a new
 ;;^DD(.4044,14,21,2,0)
 ;;=value for this field.  If the code sets DDSERROR, the value will
 ;;^DD(.4044,14,21,3,0)
 ;;=be rejected.  You might also want to ring the bell and make a call to
 ;;^DD(.4044,14,21,4,0)
 ;;=HLP^DDSUTL to display a message to the user that indicates the reason the
 ;;^DD(.4044,14,21,5,0)
 ;;=value was rejected.
 ;;^DD(.4044,14,"DT")
 ;;=2930820
 ;;^DD(.4044,20.1,0)
 ;;=READ TYPE^S^D:DATE;F:FREE TEXT;L:LIST OR RANGE;N:NUMERIC;P:POINTER;S:SET OF CODES;Y:YES OR NO;DD:DATA DICTIONARY;^20;1^Q

DINIT29D
DINIT29D ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29E S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,20.1,21,0)
 ;;=^^1^1^2930812^^
 ;;^DD(.4044,20.1,21,1,0)
 ;;=Enter the data type of this form-only field.
 ;;^DD(.4044,20.1,"DT")
 ;;=2930812
 ;;^DD(.4044,20.2,0)
 ;;=PARAMETERS^F^^20;2^K:$L(X)>2!($L(X)<1) X
 ;;^DD(.4044,20.2,3)
 ;;=Answer must be 1-2 characters in length.
 ;;^DD(.4044,20.2,21,0)
 ;;=^^8^8^2940907^
 ;;^DD(.4044,20.2,21,1,0)
 ;;=This property coressponds to the parameters that can be used in the first
 ;;^DD(.4044,20.2,21,2,0)
 ;;=^-piece of the DIR(0) input variable to ^DIR.  The "O" parameter has no
 ;;^DD(.4044,20.2,21,3,0)
 ;;=effect, since the Required property can be used to make a field required.
 ;;^DD(.4044,20.2,21,4,0)
 ;;=The "A" and "B" parameters also have no effect.
 ;;^DD(.4044,20.2,21,5,0)
 ;;= 
 ;;^DD(.4044,20.2,21,6,0)
 ;;=Free text fields can use the "U" parameter.
 ;;^DD(.4044,20.2,21,7,0)
 ;;=List or Range fields can use the "C" parameter.
 ;;^DD(.4044,20.2,21,8,0)
 ;;=Set of Codes fields can use the "X" and "M" parameters.
 ;;^DD(.4044,20.2,"DT")
 ;;=2930812
 ;;^DD(.4044,20.3,0)
 ;;=QUALIFIERS^F^^20;3^K:$L(X)>100!($L(X)<1) X
 ;;^DD(.4044,20.3,3)
 ;;=Answer must be 1-100 characters in length.
 ;;^DD(.4044,20.3,21,0)
 ;;=^^14^14^2940908^^
 ;;^DD(.4044,20.3,21,1,0)
 ;;=This property corresponds to the second ^-piece of the DIR(0) input
 ;;^DD(.4044,20.3,21,2,0)
 ;;=variable to ^DIR.  For Data Dictionary type form only fields, it
 ;;^DD(.4044,20.3,21,3,0)
 ;;=identifies the file and field.
 ;;^DD(.4044,20.3,21,4,0)
 ;;= 
 ;;^DD(.4044,20.3,21,5,0)
 ;;=Valid qualifiers are:
 ;;^DD(.4044,20.3,21,6,0)
 ;;= 
 ;;^DD(.4044,20.3,21,7,0)
 ;;=  Date             Minimum date:Maximum date:%DT
 ;;^DD(.4044,20.3,21,8,0)
 ;;=  Free Text        Minimum length:Maximum length
 ;;^DD(.4044,20.3,21,9,0)
 ;;=  List or Range    Minimum:Maximum:Maximum decimals
 ;;^DD(.4044,20.3,21,10,0)
 ;;=  Numeric          Minimum:Maximum:Maximum decimals
 ;;^DD(.4044,20.3,21,11,0)
 ;;=  Pointer          Global root or #:DIC(0)
 ;;^DD(.4044,20.3,21,12,0)
 ;;=  Set of Codes     Code:Stands for;Code:Stands for;
 ;;^DD(.4044,20.3,21,13,0)
 ;;=  Yes or No
 ;;^DD(.4044,20.3,21,14,0)
 ;;=  Data Dictionary  file#,field#
 ;;^DD(.4044,20.3,"DT")
 ;;=2930812
 ;;^DD(.4044,21,0)
 ;;=HELP^.404421^^21;0
 ;;^DD(.4044,21,"DT")
 ;;=2930812
 ;;^DD(.4044,22,0)
 ;;=INPUT TRANSFORM^K^^22;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,22,3)
 ;;=Enter standard MUMPS code.
 ;;^DD(.4044,22,9)
 ;;=@
 ;;^DD(.4044,22,21,0)
 ;;=^^3^3^2940908^
 ;;^DD(.4044,22,21,1,0)
 ;;=This is MUMPS code that can examine X, the value entered by the user, and
 ;;^DD(.4044,22,21,2,0)
 ;;=kill X if it is invalid.  It corresponds to the third ^-piece of the
 ;;^DD(.4044,22,21,3,0)
 ;;=DIR(0) input variable to ^DIR.
 ;;^DD(.4044,22,"DT")
 ;;=2930812
 ;;^DD(.4044,23,0)
 ;;=SAVE CODE^K^^23;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,23,3)
 ;;=Enter Standard MUMPS code.
 ;;^DD(.4044,23,9)
 ;;=@
 ;;^DD(.4044,23,21,0)
 ;;=^^8^8^2930920^^
 ;;^DD(.4044,23,21,1,0)
 ;;=This is MUMPS code that is executed when the user issues a Save command
 ;;^DD(.4044,23,21,2,0)
 ;;=and the value of this field changed since the last Save.  You can use this
 ;;^DD(.4044,23,21,3,0)
 ;;=field to save in global or local variables the value the user enters into
 ;;^DD(.4044,23,21,4,0)
 ;;=this field.  The following variables are available:
 ;;^DD(.4044,23,21,5,0)
 ;;= 
 ;;^DD(.4044,23,21,6,0)
 ;;=     X      = The new value of the field in internal form
 ;;^DD(.4044,23,21,7,0)
 ;;=     DDSEXT = The new value of the field in external form
 ;;^DD(.4044,23,21,8,0)
 ;;=     DDSOLD = The original (pre-save) value of the field in internal form
 ;;^DD(.4044,23,"DT")
 ;;=2930812
 ;;^DD(.4044,24,0)
 ;;=SCREEN^K^^24;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(.4044,24,3)
 ;;=Enter standard MUMPS code that sets the variable DIR("S").
 ;;^DD(.4044,24,9)
 ;;=@
 ;;^DD(.4044,24,21,0)
 ;;=^^4^4^2940908^
 ;;^DD(.4044,24,21,1,0)
 ;;=This screen is valid only for pointer and set-type form-only fields.
 ;;^DD(.4044,24,21,2,0)
 ;;= 
 ;;^DD(.4044,24,21,3,0)
 ;;=You can enter MUMPS code that sets the variable DIR("S"), to screen the
 ;;^DD(.4044,24,21,4,0)
 ;;=the values that can be selected.
 ;;^DD(.4044,24,"DT")
 ;;=2930812
 ;;^DD(.4044,30,0)
 ;;=COMPUTED EXPRESSION^FX^^30;E1,245^K:$L(X)>245!($L(X)<1) X I $D(X) D CEXPR^DDSIT
 ;;^DD(.4044,30,3)
 ;;=Answer must be 1-245 characters in length.

DINIT29E
DINIT29E ;SFISC/MKO-SCREENMAN FILES ;11/28/94  11:42 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) G:X="" ^DINIT29P S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
Q Q
 ;;^DD(.4044,30,21,0)
 ;;=^^13^13^2940908^
 ;;^DD(.4044,30,21,1,0)
 ;;=You can enter MUMPS code that sets the variable Y equal to the value of
 ;;^DD(.4044,30,21,2,0)
 ;;=the computed field.  Alternatively, you can precede the computed
 ;;^DD(.4044,30,21,3,0)
 ;;=expression with an equal sign (=).
 ;;^DD(.4044,30,21,4,0)
 ;;= 
 ;;^DD(.4044,30,21,5,0)
 ;;=For example,
 ;;^DD(.4044,30,21,6,0)
 ;;= 
 ;;^DD(.4044,30,21,7,0)
 ;;=       S:$D(var)#2 Y="The value is: "_{NUMERIC}
 ;;^DD(.4044,30,21,8,0)
 ;;=       ={FIRST NAME}_" "_{LAST NAME}
 ;;^DD(.4044,30,21,9,0)
 ;;=       ={FO(PRICE)}*1.085
 ;;^DD(.4044,30,21,10,0)
 ;;= 
 ;;^DD(.4044,30,21,11,0)
 ;;=NUMERIC, FIRST NAME, and LAST NAME are the name of FileMan fields used on
 ;;^DD(.4044,30,21,12,0)
 ;;=the form, and PRICE is the caption of a form-only field found on the
 ;;^DD(.4044,30,21,13,0)
 ;;=current page and block of the form.
 ;;^DD(.4044,30,"DT")
 ;;=2931201
 ;;^DD(.404421,0)
 ;;=HELP SUB-FIELD^^.01^1
 ;;^DD(.404421,0,"DT")
 ;;=2930218
 ;;^DD(.404421,0,"NM","HELP")
 ;;=
 ;;^DD(.404421,0,"UP")
 ;;=.4044
 ;;^DD(.404421,.01,0)
 ;;=HELP^W^^0;1^Q
 ;;^DD(.404421,.01,21,0)
 ;;=^^3^3^2940908^
 ;;^DD(.404421,.01,21,1,0)
 ;;=This text is displayed when the user enters ? at this form-only field.
 ;;^DD(.404421,.01,21,2,0)
 ;;=The lines in this word processing field correspond to the nodes in the
 ;;^DD(.404421,.01,21,3,0)
 ;;=DIR("?",#) input array to ^DIR.
 ;;^DD(.404421,.01,"DT")
 ;;=2930812

DINIT29P
DINIT29P ;SFISC/MKO-SCREENMAN POSTINIT ;11:29 AM  7 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Updated Field Type field of fields on old blocks.
 ;Convert 0 or null to 3 (data dictionary field)
 N B,F
 S B=0 F  S B=$O(^DIST(.404,B)) Q:B'=+B  D
 . Q:$P($G(^DIST(.404,B,0)),U)?1"DDGF".E
 . S F=0 F  S F=$O(^DIST(.404,B,40,F)) Q:F'=+F  D
 .. Q:$D(^DIST(.404,B,40,F,0))[0
 .. S:'$P(^DIST(.404,B,40,F,0),U,3) $P(^(0),U,3)=3
 ;
 ;Rename two version 19 options
 I $P($G(^DIC(19,0)),U)="OPTION" D
 . D:$D(^DIC(19,"B","DDS CREATE FORM")) RENAME("DDS CREATE FORM","DDS EDIT/CREATE A FORM")
 . D:$D(^DIC(19,"B","DDS CREATE BLOCK")) RENAME("DDS CREATE BLOCK","DDS RUN A FORM")
 ;
 G ^DINIT3
 ;
RENAME(DDSOLD,DDSNEW) ;Rename options
 N DIC,X,Y
 S DIC="^DIC(19,",DIC(0)="Z",X=DDSOLD
 D ^DIC Q:Y<0
 ;
 N DIE,DA,DR
 S DIE=DIC,DA=+Y,DR=".01///"_DDSNEW
 D ^DIE
 Q
 ;
PRE ;ScreenMan pre-init
 ;Delete old forms and blocks used by the Form Editor
 F I=1:1:6 K ^DIST(.403,".4030"_I)
 F I=1:1:8 K ^DIST(.403,".4040"_I)
 F I=11:1:13,21,22,31,41,51,61 K ^DIST(.404,".4030"_I)
 F I=11,21,31:1:34,41,42,51,52,61:1:63,71,81 K ^DIST(.404,".4040"_I)
 Q

DINIT3
DINIT3 ;SFISC/GFT-INITIALIZE VA FILEMAN ;5/23/96  10:37
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S ^DIC(.2,0)="DESTINATION^.21^",^(0,"GL")="^DIC(.2,"  S ^DIC(.5,0)="FUNCTION^.5I",^(0,"GL")="^DD(""FUNC"",",(^("LAYGO"),^("WR"))="@",^("DD")=U
 S ^DIC(.2,"%D",0)="^^2^2^2940908^"
 S ^DIC(.2,"%D",1,0)="This file stores destinations of data (e.g., a specific form or"
 S ^DIC(.2,"%D",2,0)="system).  A field can be associated with a destination of its data."
 S $P(^DIC(1.1,0),U,1,2)="AUDIT^1.1",^(0,"GL")="^DIA(" D A1
 S ^DIC(1.1,"%D",0)="^^1^1^2940908^"
 S ^DIC(1.1,"%D",1,0)="This file stores an audit trail of changes made to data fields."
 S $P(^DIAR(1.11,0),U,1,2)="ARCHIVAL ACTIVITY^1.11I",$P(^DIC(1.11,0),U,1,2)="ARCHIVAL ACTIVITY^1.11I",^(0,"GL")="^DIAR(1.11," D A1
 S $P(^DIAR(1.12,0),U,1,2)="FILEGRAM HISTORY^1.12DI",$P(^DIC(1.12,0),U,1,2)="FILEGRAM HISTORY^1.12DI",^(0,"GL")="^DIAR(1.12," D A1
 S $P(^DIAR(1.13,0),U,1,2)="FILEGRAM ERROR LOG^1.13",$P(^DIC(1.13,0),U,1,2)="FILEGRAM ERROR LOG^1.13",^(0,"GL")="^DIAR(1.13," D A1
 S $P(^DDA(0),U,1,2)="DD AUDIT^.6I",^DIC(.6,0,"GL")="^DDA(" D A1
 S $P(^DIST(.403,0),U,1,2)="FORM^.403I",^DIC(.403,0)="FORM^.403",^(0,"GL")="^DIST(.403," D A1
 S $P(^DIST(.404,0),U,1,2)="BLOCK^.404",^DIC(.404,0)="BLOCK^.404",^(0,"GL")="^DIST(.404," D A1
 S $P(^DIST(1.2,0),U,1,2)="ALTERNATE EDITOR^1.2",^DIC(1.2,0)="ALTERNATE EDITOR^1.2",^(0,"GL")="^DIST(1.2," D A1
 S $P(^DI(.81,0),U,1,2)="DATA TYPE^.81",^DIC(.81,0)="DATA TYPE^.81",^(0,"GL")="^DI(.81," D A1
 S $P(^DIST(.44,0),U,1,2)="FOREIGN FORMAT^.44I",^DIC(.44,0)="FOREIGN FORMAT^.44",^(0,"GL")="^DIST(.44," D A1
 S $P(^DI(.83,0),U,1,2)="COMPILED ROUTINE^.83",$P(^DIC(.83,0),U,1,2)="COMPILED ROUTINE^.83",^(0,"GL")="^DI(.83," D A1
 S D=0 F I="^DIPT(","^DIBT(","^DIE(" S X=$P("PRINT^SORT^INPUT",U,D+1)_" TEMPLATE",Y=D/1000+.4,^DD(Y,0,"NM",X)="",^DD(Y,.01,1,1,0)=Y_"^B",@("$P("_I_"0),U,1,2)=X_U_Y_""I"""),^DIC(Y,0)=X_"^"_Y,^(0,"GL")=I,D=D+1,^("WR")=U,^("DD")=U,^DIC("B",X,Y)=""
 ;
 F I=.2,.4,.5,.6,.7,.601,.602,.401,.4001,.4011,.4012,.402,.4021,.41,.411,.21,1,1.005,1.01,1.1,1.11,1.113,1.1132,1.12,1.13,1.1321,1.14,.403,.4031,.403115,.40315,.4032,.404,.40415,.4044,1.2,1.207,.44,.441,.4411,.447,.448,.42,.81 D XX
 F I=.4014,.40141,.401418,.401419,.83,.404421 D XX
 F DIK="^DIC(.2,","^DIPT(","^DIST(1.2,","^DIST(.44,","^DI(.81,","^DIST(.403,","^DIST(.404,","^DI(.85," D X
 I '$D(^DD("VERSION"))#2 F DIK="^DIC(","^DIBT(","^DIE(" D X
 S ^DD("FUNC",0)="COMPUTED-FIELD FUNCTION^.5^"
 I $D(^DD("FUNC",7,1)),$D(^DD("VERSION")),^("VERSION")>15.4
 E  S ^DD("FUNC",7,1)="C X S X="""""
 G ^DINIT4
 ;
XX S DA(1)=I,DIK="^DD("_I_","
X W ".." G IXALL^DIK
 ;
A S (^("RD"),^("LAYGO"),^("WR"),^("DD"))=U Q
A1 S (^("DEL"),^("LAYGO"),^("WR"),^("DD"))=U Q
 ;

DINIT4
DINIT4 ;SFISC/GFT-INITIALIZE VA FILEMAN ;9/19/91  11:49 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$E($T(DD+I),4,999) G ^DINIT41:X?.P S ^DD("FUNC",I,0)=$P(X,";",1),Y=1 F DU=1,2,3,9,10 S Y=Y+1 I $P(X,";",Y)]"" S ^(DU)=$P(X,";",Y)
 ;;SQUAREROOT;D SQR^DIXC S X=$S(X'>0:"",1:Y);;;
 ;;TIME;S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M";;;
 ;;MONTH;S X=$E(X,1,5)_0_0 S:'X X="";D^D;;
 ;;YEAR;S X=$E(X,1,3)_"0000" S:'X X="";D^D;;
 ;;DATE;S X=$P(X,".",1);D^D;;
 ;;DAYOFWEEK;D DW^%DTC;^D;;
 ;;CLOSE
 ;;ABS;S:X<0 X=-X;;;
 ;;INTERNAL;S X=X;;;
 ;;MAX;S:X1>X X=X1;O;2;MAXIMUM OF 2 VALUES
 ;;MIN;S:X1<X X=X1;O;2;MINIMUM OF TWO VALUES
 ;;REVERSE;S Y=X,X="" X "F %=$L(Y):-1:1 S X=X_$E(Y,%)";;;DATA CHARACTERS IN RIGHT-TO-LEFT ORDER
 ;;UPPERCASE;X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)";;;
 ;;LOWERCASE;X "F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)";;;
 ;;CENTER;S X=$J("",$S($D(DIWR)+$D(DIWL)=2:DIWR-DIWL+1,$D(IOM):IOM,1:80)-$L(X)\2-$X)_X;;;;W
 ;;UNDERLINE;S %="",Y=$S($D(IOST)[0:-1,$A(IOST)-80:-1,1:$L(X)<83) X:Y+1 "F Y=1:1:$L(X) "_$S(Y:"S %=$C(8)_%",1:"W $E(X,Y),$C(8)")_"_""_""" S:Y+1 X=$S(%]"":X_%,1:%);;;UNDERLINE (ARG) IF OUTPUTTING TO A PRINTER DEVICE;W
 ;;PAGEFEED;S %Y=1,%=$S($D(DIWF):$F(DIWF,"B"),1:0) X:% "F %Y=%:1 Q:$E(DIWF,%Y)'?1N" S:$D(DIWF) DIWF=$E(DIWF,1,%-2)_$E(DIWF,%Y,999)_"B"_(X\1) X:X>(IOSL-$Y)&$D(^UTILITY($J,1))&'$D(^("W"))&'$D(DIWF) ^(1) S X="";;;START NEW PAGE IF <ARG LINES LEFT;W
 ;;BREAKABLE;D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,1);;;OUTPUT DEVICE CAN BE INTERRUPTED IF ARGUMENT IS NON-ZERO
 ;;NUMMONTH;S X=+$E(X,4,5);^D;;MONTH NUMBER (0-12) FOR A DATE
 ;;NUMDAY;S X=+$E(X,6,7);^D;;DAY NUMBER (0-31) FOR A DATE
 ;;NUMYEAR;S:X X=$E(X,2,3);^D;;YEAR NUMBER (00-99) FOR A DATE
 ;;NUMDATE;S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3);^D;;DATE IN 'NN/NN/NN' FORMAT
 ;;REPLACE;X "F %=0:0 S %=$F(X2,X1,%) Q:%<2  S X2=$E(X2,1,%-$L(X1)-1)_X_$E(X2,%,999),%=%-$L(X1)+$L(X)" S X=X2;;3;THE 1ST ARGUMENT, WITH ALL OCCURRENCES OF THE 2ND ARGUMENT REPLACED BY THE 3RD
 ;;NOW;S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100);D;0;CURRENT DATE/TIME
 ;;TODAY;S X=DT;D;0;CURRENT DATE
 ;;PAGE;S X=$S($D(DC)#2:DC,1:"");;0;PAGE NUMBER (OF OUTPUT)
 ;;SETTAB;S DIWT=X,X="" F %=1:1 S Y="X"_% Q:'$D(@Y)  S DIWT=@Y_","_DIWT;;VARIABLE;SET TAB STOPS;W
 ;;RIGHT-JUSTIFY;S X="" S:'$D(DIWF) DIWF="" S:DIWF'["R" DIWF=DIWF_"R";;0;;W
 ;;DOUBLE-SPACE;S X="" S:'$D(DIWF) DIWF="" S:DIWF'["D" DIWF=DIWF_"D";;0;;W
 ;;SINGLE-SPACE;S:'$D(DIWF) DIWF="" S X="",DIWF=$P(DIWF,"D",1)_$P(DIWF,"D",2);;0;;W

DINIT41
DINIT41 ;SFISC/GFT-INITIALIZE VA FILEMAN ;4/14/93  1:15 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DD F I=1:1 S X=$E($T(DD+I),4,999) G ^DINIT42:X?.P S ^DD("FUNC",I+30,0)=$P(X,";",1),Y=1 F DU=1,2,3,9,10 S Y=Y+1 I $P(X,";",Y)]"" S ^(DU)=$P(X,";",Y)
 ;;BLANK;X "F I=1:1:X "_$S($D(^UTILITY($J,"W")):"S X="" |TAB|"" D L^DIWP",1:"W !") S X="";;;SKIP (ARG) NUMBER OF LINES;W
 ;;MONTHNAME;S X=$P("JANUARY^FEBRUARY^MARCH^APRIL^MAY^JUNE^JULY^AUGUST^SEPTEMBER^OCTOBER^NOVEMBER^DECEMBER","^",+X);;;TURNS "1" INTO "JANUARY", "2" INTO "FEBRUARY", ETC.
 ;;SETPAGE;S DC=X,X="";;;PAGE NUMBER ON NEXT PAGE WILL BE (ARG)+1;W
 ;;INDENT;S:'$D(DIWF) DIWF="" S %Y=1,%=$F(DIWF,"I") X:% "F %Y=%:1 Q:$E(DIWF,%Y)'?1N" S DIWF=$E(DIWF,1,%-2)_$E(DIWF,%Y,999)_"I"_(X\1),X="";;;INDENT FOLLOWING TEXT (ARG) SPACES;W
 ;;SITENUMBER;S X=^DD("SITE",1);;0;NUMBER IDENTIFYING YOUR SITE (FROM INITIALIZATION)
 ;;WIDTH;S:'$D(DIWF) DIWF="" S %Y=1,%=$F(DIWF,"C") X:% "F %Y=%:1 Q:$E(DIWF,%Y)'?1N" S DIWF=$E(DIWF,1,%-2)_$E(DIWF,%Y,999)_"C"_(X\1),X="";;;DISPLAY FOLLOWING TEXT (ARG) COLUMNS ACROSS;W
 ;;PAGESTART;S:'$D(DIWF) DIWF="" S %Y=1,%=$F(DIWF,"T") X:% "F %Y=%:1 Q:$E(DIWF,%Y)'?1N" S DIWF=$E(DIWF,1,%-2)_$E(DIWF,%Y,999)_"T"_(X\1),X="";;;START NEW OUTPUT TEXT ON LINE (ARG) OF PAGE;W
 ;;NOWRAP;S:'$D(DIWF) DIWF="" S:DIWF'["N" DIWF=DIWF_"N" S X="";;0;DISPLAY LINE-FOR-LINE AS INPUT;W
 ;;WRAP;S DIWF=$P(DIWF,"N",1)_$P(DIWF,"N",2),X="";;0;RETURN TO 'WRAP-AROUND' OUTPUT;W
 ;;MINUTES;S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S X=X*1440+Y;;2;DIFFERENCE BETWEEN 2 DATE/TIMES IN MINUTES
 ;;MODULO;S X=X1#X;;2;FIRST ARGUMENT MOD SECOND ARGUMENT (MUMPS '#' OPERATOR)
 ;;SET;S:X]""&(X'[U)&(X'["$C(94)") @X=X1,X=X1;;2;TAKES THE VALUE OF 1ST ARGUMENT, BUT ALSO PUTS IT INTO THE VARIABLE NAMED BY THE 2ND ARGUMENT
 ;;BETWEEN;S:X<X1 %=X1,X1=X,X=% S X=X2'>X&(X2'<X1);;3;EQUALS '1' IF 1ST ARGUMENT LIES BETWEEN 2ND AND 3RD, '0' OTHERWISE
 ;;TOP;S DIFF=1 X:$D(^UTILITY($J,1)) ^(1) S X="";;0;TOP-OF-FORM;W
 ;;NOBLANKLINE;S X="",DIWF=$S($D(DIWF):DIWF_" ",1:" ");;0;SUPPRESSES PRINTING OF A SINGLE ALL-BLANK LINE;W
 ;;RANGEDATE;S %Y=X3,Y=X2,X2=X S:X>X1 X2=X1,X1=X S:Y>%Y %Y=Y,Y=X3 S:Y>X2 X2=Y S:%Y<X1 X1=%Y D ^%DTC S X=$S(%Y=0:0,X<0:0,1:X+1) K %Y,X3;;4;TAKES 2 DATE RANGES, RETURNS THE NUMBER OF DAYS BY WHICH THEY OVERLAP, OR 0 IF OVERLAP IS INDEFINITE
 ;;SETPARAM;S:X]""&(X?.ANP)&(X1'[U)&(X1'["$C(94)") DIPA($E(X,1,30))=X1 S X="";;2;RETURNS NOTHING, BUT SETS PARAMETER NAMED BY 2ND ARGUMENT TO 1ST ARGUMENT

DINIT42
DINIT42 ;SFISC/XAK-INITIALIZE VA FILEMAN ;1/10/91  1:43 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %=47
DD F I=1:5 S X=$E($T(DD+I),4,999),%=%+1 G FUNC:X?.P S ^DD("FUNC",%,0)=$P(X,";"),Y=I F DU=1,2,3,9 S Y=Y+1,X=$E($T(DD+Y),4,999) I X]"" S ^(DU)=X
 ;;PARAM
 ;;S X=$S(X=""!(X'?.ANP):"",$D(DIPA($E(X,1,30))):DIPA($E(X,1,30)),1:"")
 ;;
 ;;
 ;;RETURNS VALUE OF PARAMETER NAMED BY ARGUMENT
 ;;IOM
 ;;S X=$S($D(IOM):IOM,1:80)
 ;;
 ;;0
 ;;RETURNS THE NUMBER OF COLUMN POSITIONS ON THE PAGE OR SCREEN (E.G., 80)
 ;;DUP
 ;;S %=X,X="" Q:X1=""  S $P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%)
 ;;
 ;;2
 ;;DUPLICATES THE 1ST ARGUMENT INTO AN 'N'-BYTE STRING, WHERE 'N' IS 2ND ARGUMENT
 ;;STRIPBLANKS
 ;;X:X[" " "F %=0:0 Q:$A(X)-32  S X=$E(X,2,999)","F %=0:0 S %=$L(X) Q:$A(X,%)-32  S X=$E(X,1,%-1)"
 ;;
 ;;
 ;;DELETES LEADING AND TRAILING SPACES FROM THE ARGUMENT STRING
 ;;TRANSLATE
 ;;X "F %=1:1:$L(X1) F %Y=0:0 S %Y=$F(X2,$E(X1,%),%Y) Q:'%Y  S I=$E(X,%),X2=$E(X2,1,%Y-2)_I_$E(X2,%Y,999) S:I="""" %Y=%Y-1" S X=X2
 ;;
 ;;3
 ;;REPLACES, IN ARG1, EACH OCCURRENCE OF EACH CHAR IN ARG2 WITH THE CORRESPONDING CHAR IN ARG3
 ;;PADRIGHT
 ;;S:$L(X1)<X X1=X1_$J("",X-$L(X1)) S X=X1
 ;;
 ;;2
 ;;RETURNS 'ARG1', WITH SPACES ADDED TO GENERATE A STRING 'ARG2' BYTES LONG
 ;;FILE
 ;;S X=$S('X:X,X'["(":X,'$D(@(U_$E($P(X,+X,2,99),2,99)_"0)")):X,1:$P(^(0),U))
 ;;
 ;;1
 ;;Names file for variable pointer type fields.
 ;;USER
 ;;S %=$S($D(^VA(200,+DUZ,0)):^(0),1:""),X=$S('DUZ:"??",X="#":DUZ,X="N":$P(%,U,1),X="I":$P(%,U,2),X="T":$S($D(^DIC(3.1,+$P(%,U,9),0)):$P(^(0),U,1),1:""),X="NN":$S($D(^VA(200,+DUZ,.1)):$P(^(.1),U,4),1:""),1:"??") K %
 ;;
 ;;1
 ;;RETURNS USER ATTRIBUTES: #=NUMBER,N=NAME,I=INITIAL,T=TITLE,NN=NICKNAME
 ;;VAR
 ;;Q:X[U!(X["$C(94)")!X  S X=$S($D(@X):@X,1:"")
 ;;
 ;;1
 ;;RETURNS VALUE OF A LOCAL VARIABLE IF IT'S THERE
 ;;SETDATA
 ;;S X1=X
 ;;
 ;;2
 ;;SETS FIRST ARGUMENT EQUAL TO THE SECOND ARGUMENT
 ;;NOON
 ;;S %DT="XR",X="T@NOON" D ^%DT S X=+Y
 ;;D
 ;;0
 ;;RETURNS THE CURRENT DATE AND THE TIME VALUE OF 12:OO.
 ;;MID
 ;;S %DT="XR",X="T@MID" D ^%DT S X=+Y
 ;;D
 ;;0
 ;;RETURNS THE CURRENT DATE AND THE TIME VALUE OF 24:00.
 ;;
FUNC F I=2:1:8 S X=$T(FUNC+I),^DD("FUNC",I+91,0)=$P(X,";",3),^(9)=$P(X,";",4)
 G ^DINIT5
 ;;MAXIMUM;TAKES MULTIPLE-VALUED FIELD AS ARGUMENT.  RETURNS THE MAXIMUM VALUE OF ALL THE MULTIPLES.
 ;;MINIMUM;TAKES MULTIPLE-VALUED FIELD AS ARGUMENT.  RETURNS THE MINIMUM VALUE OF ALL THE MULTIPLES.
 ;;NEXT;TAKES SINGLE-VALUED FIELD AS ARGUMENT.  RETURNS THE VALUE THAT THAT FIELD HAS IN THE NEXT ENTRY OR SUB-ENTRY.
 ;;PREVIOUS;TAKES SINGLE-VALUED FIELD AS ARGUMENT.  RETURNS THE VALUE THAT THAT FIELD HAS IN THE PREVIOUS ENTRY OR SUB-ENTRY.
 ;;TOTAL;TAKES MULTIPLE-VALUED FIELD AS ARGUMENT.  RETURNS THE TOTAL OF ALL THE MULTIPLES FOR WHICH THERE ARE VALUES.
 ;;COUNT;TAKES MULTIPLE-VALUED FIELD (OR FILE NAME) AS ARGUMENT.  RETURNS THE NUMBER OF MULTIPLES CURRENTLY EXISTING.
 ;;LAST;TAKES MULTIPLE-VALUED FIELD NAME AS ARGUMENT.  RETURNS THE VALUE OF THE LAST MULTIPLE.

DINIT5
DINIT5 ;SFISC/GFT-INITIALIZE VA FILEMAN ;8/3/94  1:50 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^DOPT("DDS"),^("DDU"),^("DIAR"),^("DIAU"),^("DIBT"),^("DICATT"),^("DICR"),^("DID"),^("DIFG"),^("DII"),^("DII1"),^("DIS"),^("DIT"),^("DIU"),^("DIX"),^("DIAX"),^("DDXP")
 S ^DOPT("DICATT",0)="DATA TYPE^1.01"
 F I=1:1:9 S ^DOPT("DICATT",I,0)=$P("DATE/TIME^NUMERIC^SET OF CODES^FREE TEXT^WORD-PROCESSING^COMPUTED^POINTER TO A FILE^VARIABLE-POINTER^MUMPS",U,I)
 S ^DOPT("DIS",0)="CONDITION^1.01",^DOPT("DID",0)="LISTING FORMAT^1.01"
 F I=1:1:6 S ^DOPT("DIS",I,0)=$P("NULL^^1;CONTAINS^[^1;MATCHES^^1;LESS THAN^<^;EQUALS^=^1;GREATER THAN^>^",";",I) S:I-1&(I-3) ^DOPT("DIS","B",$P(^(0),U,2),I)=1
 F I=1:1:7 S ^DOPT("DID",I,0)=$P("STANDARD^BRIEF^CUSTOM-TAILORED^MODIFIED STANDARD^TEMPLATES ONLY^GLOBAL MAP^CONDENSED",U,I)
 F I="DID","DIS","DICATT" S DIK="^DOPT("""_I_"""," D IXALL^DIK
 S DIK="^DD(""FUNC""," D IXALL^DIK
 D DT^DICRW I '$D(^DD("VERSION")) D FIX S %="" F I=0:0 S %=$O(^DISV(%)) G V:%="" K ^DISV(%)
 F I=2:1:6 W ".." I ^("VERSION")<$P("^14.3^14.7^16^16.07^16.39",U,I) D @("FIX"_I) Q
V K ^DD(0,"B","HELP FRAME") G ^DINIT6
 ;
FIX ;
 N DIDUZ
 S U="^",DH="DIC("
 F D=0:1 Q:$O(^DIBT(D))'>0
 S DIDUZ=0 F  S DIDUZ=+$O(^DISV(DIDUZ)) Q:'DIDUZ  S I=0 F  S I=$O(^DISV(DIDUZ,I)) Q:I'>0  I $O(^(I,0))>0 D PUT
 S DIK="^DIBT(" D IXALL^DIK G FIX2
 ;
PUT S X=^(0),Y=U_$P(X,U,2) I Y]U,@("$D("_Y_"0))") S DIC=+$P(^(0),U,2) I $D(^DIC(DIC,0,"GL")),^("GL")=Y G GOT
 Q
GOT S D=D+1,^DIBT(D,0)=$P(X,U,1)_U_$P(X,U,3)_U_U_+DIC_U_DIDUZ
 S X=0 F  S X=$O(^DISV(DIDUZ,I,X)) Q:X'>0  S ^DIBT(D,1,X)=""
 S Y="",X=0 F  S Y=$O(^DISV(DIDUZ,I,0,Y)) Q:Y=""  S ^DIBT(D,"DIS",Y)=^(Y)
 S Y=-1 Q
 ;
UP S D=0 F  S D=$O(^DD(J,D)) Q:D'>0  I $D(^(D,0)),$P(^(0),U,2)>J S J(+$P(^(0),U,2))=J
 S:D="" D=-1 S J=$O(J(0)) S:J="" J=-1 Q:J<0  S ^DD(J,0,"UP")=J(J) K J(J) G UP
 ;
FIX2 S I=1 F  S I=$O(^DIC(I)) Q:I'>0  I $D(^(I,0,"GL")),@("$D("_^("GL")_"0))"),$P(^(0),U,2)["N",'$D(^DD(I,.001)) S ^(.001,0)="NUMBER^N^^ ^K:$L(X)>9 X I $D(X) K:+X'=X!(X'>0) X",^DD(I,"B","NUMBER",.001)=""
 S I=0 F  S I=$O(^DD(I)) Q:I'>0  S J=0 F  S J=$O(^DD(I,J)) Q:J'>0  S X=$P(^(J,0),U,2),F=$F(X,"P") I 'X,F,'$E(X,F,99),@("$D(^"_$P(^(0),U,3)_"0))") S P=+$P(^(0),U,2),^(0)=$P(^DD(I,J,0),U,1)_U_$E(X,1,F-1)_P_$E(X,F,99)_U_$P(^(0),U,3,99)
 ;
FIX3 S I=.9 F  S I=$O(^DIPT(I)) Q:I'>0  I $D(^(I,0)) S X=$P(^(0),U,3) I $P(^(0),U,6)="" S ^(0)=$P(^(0)_"^^^^",U,1,5)_U_X
 S:I="" I=-1 S DD=1 F  S DD=$O(^DD(DD)) Q:DD'>0  S %=0 F  S %=$O(^DD(DD,"SB",%)) Q:%=""  S ^DD(%,0,"UP")=DD
 S:DD="" DD=-1 S %=-1
 ;
FIX4 S F=1 F  S F=$O(^DD(F)) Q:F'>0  I $D(^(F,"GR")) K ^("GR") S DIK="^DD("_F_",",DA(1)=F D IXALL^DIK
 ;
FIX5 S F=1 F  S F=$O(^DIC(F)) Q:F'>0  S I=$S($D(^(F,0,"DT")):^("DT"),1:0),J=$S($D(^("U")):^("U"),1:0) S:I!J ^DIC(F,"%A")=J_U_I
 ;
FIX6 K J S F=1 F  S (J,F)=$O(^DIC(F)) Q:F'>0  D UP
 S:F="" (F,J)=-1

DINIT6
DINIT6 ;SFISC/XAK-INITIALIZE VA FILEMAN ;9/1/94  11:17
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $D(^DD("OS"))[0 D OS^DINIT
 W !!,"The following files have been installed:",!
 F X=0:0 S X=$O(^DIC(X)) Q:X>1.9999  Q:'X  W $E("   ",1,(3-$L($P(X,"."))))_X,?8,$P($G(^DIC(X,0)),U),! S ^DD(X,0,"VR")=VERSION
 S ^DD("VERSION")=VERSION,X=^DD("OS",^DD("OS"),0)
 S ^DD("SUB")=$P(X,U,3),^("ROU")=$P(X,U,4)
 D 1
 D ^DINITPST
E W !,"INITIALIZATION COMPLETED IN "_($P($H,",",2)-DIT)_" SECONDS."
 D KL Q
 ;
1 N DIT
 D KL,PKG,DIINIT
 Q
 ;
KL K %,%H,%X,%Y,DD,DH,DIC,DIK,DIT,DITZS,D,DA,VERSION,DU,F,I,J,P,X,Y,DIRUT,DTOUT,DUOUT
 Q
PKG ;
 I $D(^DIC(9.4,0))#2,($P(^DIC(9.4,0),U,1)'="PACKAGE") D  Q
 . W !!,"You have a file #9.4 that is not the 'Package' file."
 . W !,"Therefore, the Package file will not be initialized on your system."
 . W !,"You cannot use VA FileMan's package export utility, DIFROM."
 . Q
 I $$ROUEXIST^DILIBF("XPDUTL"),$$VERSION^XPDUTL("XU")>7.1 Q
 K ^DD(9.4,913.5,2),^DD(9.4,914.5,2),^DD(9.4,916.5,2),^DD(9.44,222.7,2),^DD(9.44,222.9,2),^DD(9.44,1909)
 W !!,"Your Package file will now be updated.",!!
 D EN^DIPKINIT
 Q
DIINIT ;
 I $P($G(^DIC(19,0)),U,1)="OPTION",$P($G(^DIC(19.1,0)),U,1)="SECURITY KEY" D
 . W !!,"Options and security keys will now be added to your system.",!!
 . D EN^DIINIT
 . Q
 ;Put PACKAGE pointer into FM DIALOG entries, re-index file
 W !!,"Re-indexing VA FileMan entries in the DIALOG file."
 N DIPKG,DIREC S DIPKG=$O(^DIC(9.4,"C","DI",0))
 F DIREC=0:0 S DIREC=$O(^DI(.84,DIREC)) Q:'DIREC!(DIREC>10000)  D
 . S $P(^DI(.84,DIREC,0),U,4)=DIPKG
 . S DIK="^DI(.84,",DA=DIREC D IX1^DIK
 . Q
 Q

DINITPST
DINITPST ;SFISC/MKO-POST INIT FOR DINIT ;12/21/94  12:47
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;Deleted unneeded Dialog file entry
 N %,%Y,C,D,D0,DI,DIV,DQ
 ;
 ;Delete templates .001 and .002
 I $D(^DIE(.001)) D
 . N DIK,DA
 . S DIK="^DIE("
 . F DA=.001,.002 D ^DIK
 ;
 ;Recompile all forms
 W !
 S DDSQUIET=1 D DELALL^DDSZ K DDSQUIET
 D ALL^DDSZ
 W !!
 Q

DINTEG
DINTEG ;SFISC/dizSUM FILEMAN-FileMan checksum checker ;DEC 28, 1994@11:30:03
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIZ4="I 1" D DSP,INI
CONT F DIZ1=1:1 S DIZ2=$T(ROU+DIZ1) Q:DIZ2=""  S X=$P(DIZ2," ",1),DIZ3=$P(DIZ2,";",3) X DIZ4 I $T W !,X X DIZTEST W:'$T ?28,DIZ6 S:'$T DIZ3=0 X:DIZ3 DIZSUM W ?10,$S('DIZ3:"",DIZ3'=Y:$C(7)_"Calculated "_Y_", off by "_(Y-DIZ3),1:"ok")
 G CONT^DINTEG1
 S X="" F  S X=$O(^UTILITY($J,X)) Q:X=""  W !,X,?10,"not a routine in this INTEGRITY checker"
 K D,D1,D2,D3,X,Y,DIZ,DIZ1,DIZ2,DIZ3,DIZ4,DIZ5,DIZ6,DIZTEST,DIZSUM,DISYS,DIZSEL,^UTILITY($J) Q
ONE D INI S DIZSEL=$S($D(^%ZOSF("RSEL")):^("RSEL"),1:"F  S DIR(0)=""FO^1:8"",DIR(""A"")=""ROUTINE NAME"" D ^DIR Q:$D(DIRUT)  X DIZTEST W:'$T ?28,DIZ6 I $T S ^UTILITY($J,Y)=""""")
 S DIZ4="I $D(^UTILITY($J,X)) K ^(X)" D DSP
 W !,"Check a subset of routines:" K ^UTILITY($J) X DIZSEL
 W ! G CONT
DSP S X=$T(+2) W !!,"Checksum routine created on "_$P(X,";",6)_" by "_$P(X,";",4)_" V"_$P(X,";",3) Q
INI K ^UTILITY($J) D OS^DII S DIZTEST=$S($D(^DD("OS",DISYS,18)):^(18),1:"I $D(^ (X))"),DIZ5="",DIZ6=$C(7)_"Routine not in UCI"
 S DIZSUM="ZL @X S Y=0 F D=1,3:1 S D1=$T(+D),D3=$F(D1,"" "") Q:'D3  S D3=$S($E(D1,D3)'="";"":$L(D1),$E(D1,D3+1)="";"":$L(D1),1:D3-2) F D2=1:1:D3 S Y=$A(D1,D2)*D2+Y" Q
ROU ;;
DDBR ;;6656482
DDBR0 ;;5416202
DDBR1 ;;6994470
DDBR2 ;;6163949
DDBR3 ;;3667049
DDBR4 ;;2471318
DDBRGE ;;6779515
DDBRS ;;2651711
DDBRT ;;545522
DDBRU ;;4293844
DDBRU2 ;;6369140
DDBRZIS ;;1235043
DDGF ;;1882381
DDGF0 ;;4477329
DDGF1 ;;3080012
DDGF2 ;;4585362
DDGF3 ;;5347663
DDGF4 ;;2607874
DDGFADL ;;1121232
DDGFAPC ;;2980494
DDGFASUB ;;1650486
DDGFBK ;;4312844
DDGFBSEL ;;3244989
DDGFEL ;;5557457
DDGFFLD ;;3054325
DDGFFLDA ;;4410148
DDGFFM ;;3288743
DDGFH ;;240939
DDGFHBK ;;2815103
DDGFLOAD ;;3902698
DDGFORD ;;1345365
DDGFPG ;;6127977
DDGFSV ;;3315854
DDGFU ;;5078352
DDGFUPDB ;;1575190
DDGFUPDP ;;4297868
DDGLIB0 ;;9549853
DDGLIBH ;;5117670
DDGLIBW ;;4337005
DDGLIBW1 ;;2290469
DDIOL ;;1605858
DDMAP ;;9789930
DDMAP1 ;;11711835
DDMAP2 ;;7579160
DDS ;;5814424
DDS0 ;;3566448
DDS01 ;;6420175
DDS02 ;;3319070
DDS1 ;;4756070
DDS10 ;;2611728
DDS11 ;;6987462
DDS2 ;;8724593
DDS3 ;;1851493
DDS4 ;;4728317
DDS41 ;;6148926
DDS5 ;;3748023
DDS6 ;;3000113
DDS7 ;;4113826
DDSBOX ;;1558787
DDSCAP ;;814742
DDSCLONE ;;7839361
DDSCLONF ;;3063828
DDSCOM ;;2718993
DDSCOMP ;;2917663
DDSDBLK ;;3731849
DDSDEL ;;3237448
DDSDFRM ;;6758733
DDSFO ;;818960
DDSIT ;;758636
DDSLIB ;;3572314
DDSM ;;4207841
DDSM1 ;;1945642
DDSMSG ;;2481467
DDSOPT ;;388239
DDSPRNT ;;5807476
DDSPRNT1 ;;5755088
DDSPRNT2 ;;6371861
DDSPTR ;;5051244
DDSR ;;7658709
DDSR1 ;;1176619
DDSRSEL ;;2155464
DDSRUN ;;931423
DDSSTK ;;984511
DDSU ;;3929829
DDSUTL ;;3424694
DDSVAL ;;5793531
DDSVALF ;;7911395
DDSVALM ;;2353363
DDSWP ;;1727487
DDSZ ;;7533949
DDSZ1 ;;7045550
DDSZ2 ;;4151736
DDSZ3 ;;1057668
DDU ;;472706
DDUCHK ;;8257588
DDUCHK1 ;;9514982
DDUCHK2 ;;7981614
DDUCHK3 ;;6554582
DDW ;;3949746
DDW1 ;;3442094
DDW2 ;;2675168
DDW3 ;;7006195
DDW4 ;;3296631
DDW5 ;;4768415
DDW6 ;;5120328
DDW7 ;;2048152
DDW8 ;;4701532
DDW9 ;;4876814
DDWC ;;5373992
DDWC1 ;;2968865
DDWF ;;2289329
DDWG ;;3724454
DDWH ;;2072618
DDWK ;;785878
DDWT1 ;;4384411
DDXP ;;2355934
DDXP1 ;;8242677
DDXP2 ;;4539899
DDXP3 ;;6242061
DDXP31 ;;10768233
DDXP32 ;;4257847
DDXP33 ;;1616122
DDXP4 ;;7016440
DDXP41 ;;1471391
DDXP5 ;;883390
DDXPLIB ;;2740156
DI ;;385007
DIA ;;6481291
DIA1 ;;8353215
DIA2 ;;4082017
DIA3 ;;10625537
DIAC ;;959403
DIALOG ;;9961294
DIALOGU ;;1585021
DIAR ;;12160588
DIARA ;;14770992
DIARB ;;7839337
DIARCALC ;;1999709
DIARR ;;10340004
DIARR1 ;;10326725
DIARR2 ;;4740869
DIARR3 ;;10772756

DINTEG1
DINTEG1 ;SFISC/dizSUM FILEMAN-FileMan checksum checker ;DEC 28, 1994@11:30:03
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIZ4="I 1" D DSP,INI
CONT F DIZ1=1:1 S DIZ2=$T(ROU+DIZ1) Q:DIZ2=""  S X=$P(DIZ2," ",1),DIZ3=$P(DIZ2,";",3) X DIZ4 I $T W !,X X DIZTEST W:'$T ?28,DIZ6 S:'$T DIZ3=0 X:DIZ3 DIZSUM W ?10,$S('DIZ3:"",DIZ3'=Y:$C(7)_"Calculated "_Y_", off by "_(Y-DIZ3),1:"ok")
 G CONT^DINTEG2
 S X="" F  S X=$O(^UTILITY($J,X)) Q:X=""  W !,X,?10,"not a routine in this INTEGRITY checker"
 K D,D1,D2,D3,X,Y,DIZ,DIZ1,DIZ2,DIZ3,DIZ4,DIZ5,DIZ6,DIZTEST,DIZSUM,DISYS,DIZSEL,^UTILITY($J) Q
ONE D INI S DIZSEL=$S($D(^%ZOSF("RSEL")):^("RSEL"),1:"F  S DIR(0)=""FO^1:8"",DIR(""A"")=""ROUTINE NAME"" D ^DIR Q:$D(DIRUT)  X DIZTEST W:'$T ?28,DIZ6 I $T S ^UTILITY($J,Y)=""""")
 S DIZ4="I $D(^UTILITY($J,X)) K ^(X)" D DSP
 W !,"Check a subset of routines:" K ^UTILITY($J) X DIZSEL
 W ! G CONT
DSP S X=$T(+2) W !!,"Checksum routine created on "_$P(X,";",6)_" by "_$P(X,";",4)_" V"_$P(X,";",3) Q
INI K ^UTILITY($J) D OS^DII S DIZTEST=$S($D(^DD("OS",DISYS,18)):^(18),1:"I $D(^ (X))"),DIZ5="",DIZ6=$C(7)_"Routine not in UCI"
 S DIZSUM="ZL @X S Y=0 F D=1,3:1 S D1=$T(+D),D3=$F(D1,"" "") Q:'D3  S D3=$S($E(D1,D3)'="";"":$L(D1),$E(D1,D3+1)="";"":$L(D1),1:D3-2) F D2=1:1:D3 S Y=$A(D1,D2)*D2+Y" Q
ROU ;;
DIARR4 ;;4010759
DIARR5 ;;5439123
DIARR6 ;;5070511
DIARU ;;14044819
DIARX ;;8134238
DIAU ;;6095280
DIAX ;;7377151
DIAXERR ;;2053556
DIAXG ;;1267519
DIAXG1 ;;7996370
DIAXG2 ;;3197219
DIAXGI ;;5956398
DIAXGU ;;2267957
DIAXM ;;9420934
DIAXM1 ;;4345149
DIAXM2 ;;8396635
DIAXM3 ;;5623823
DIAXMS ;;7778891
DIAXU ;;4749815
DIAXU1 ;;4154353
DIAXU2 ;;1494240
DIAXU3 ;;2533149
DIB ;;7193228
DIBT ;;9013461
DIBT1 ;;7178879
DIC ;;9799355
DIC1 ;;7157061
DIC2 ;;3386307
DICA ;;4983313
DICA1 ;;4452180
DICA2 ;;3685071
DICA3 ;;1548694
DICATT ;;6265805
DICATT0 ;;7932864
DICATT1 ;;6222908
DICATT2 ;;9604401
DICATT22 ;;7969359
DICATT3 ;;6166227
DICATT4 ;;10657620
DICATT5 ;;6797753
DICATT6 ;;5640525
DICATTA ;;6837632
DICD ;;9944972
DICE ;;11062736
DICE0 ;;7809447
DICE1 ;;5929202
DICE2 ;;9103183
DICE3 ;;1063202
DICE4 ;;7914237
DICE7 ;;7414372
DICF ;;6837157
DICF1 ;;5555141
DICF2 ;;5350507
DICF3 ;;6340984
DICF4 ;;3617198
DICF5 ;;2906278
DICF6 ;;876049
DICL ;;4413233
DICL1 ;;2485213
DICL2 ;;6137651
DICL3 ;;3930489
DICLIB ;;471121
DICM ;;8204058
DICM0 ;;4884024
DICM1 ;;5299460
DICM2 ;;6920486
DICM3 ;;4620259
DICN ;;7476828
DICN1 ;;7148963
DICOMP ;;5808899
DICOMP0 ;;9824026
DICOMP1 ;;6095234
DICOMPV ;;7164570
DICOMPW ;;8864346
DICOMPX ;;3752529
DICOMPY ;;6302870
DICOMPZ ;;8915237
DICQ ;;8535882
DICQ1 ;;5481016
DICR ;;3769352
DICRW ;;6500587
DICRW1 ;;1020868
DICU ;;2626995
DICU1 ;;4570410
DICU2 ;;1979705
DID ;;9150099
DID1 ;;9878801
DID2 ;;10525120
DIDC ;;8081975
DIDG ;;5459532
DIDH ;;6400533
DIDH1 ;;9224809
DIDT ;;6670456
DIDTC ;;7237147
DIDU ;;5971833
DIDU1 ;;1818582
DIDU2 ;;3625878
DIDX ;;8293948
DIE ;;9505864
DIE0 ;;4635966
DIE1 ;;6179725
DIE17 ;;6822014
DIE2 ;;5770548
DIE3 ;;4863655
DIE9 ;;5112765
DIED ;;6239632
DIEF ;;6851994
DIEF1 ;;4030819
DIEFU ;;4587189
DIEFW ;;3026875
DIEH ;;6060388
DIEH1 ;;1151210
DIEQ ;;5172657
DIEQ1 ;;1766980
DIET ;;5241814
DIEV ;;9085395
DIEV1 ;;4308402
DIEZ ;;8995968
DIEZ0 ;;9127230
DIEZ1 ;;7548083
DIEZ2 ;;7389106
DIFG ;;9615801
DIFG0 ;;9271581
DIFG0A ;;5263645
DIFG0B ;;3277889
DIFG1 ;;6466432
DIFG2 ;;6268614
DIFG3 ;;11191749
DIFG3A ;;5426591
DIFG4 ;;11076453
DIFG4A ;;4158452
DIFG5 ;;11716060
DIFG6 ;;12531183
DIFG7 ;;3294917
DIFGA ;;10149588
DIFGA1 ;;1672112
DIFGB ;;7763085
DIFGG ;;5089070
DIFGG2 ;;9806486
DIFGG4 ;;5207113
DIFGGI ;;5710645
DIFGGSB ;;483886
DIFGGSB1 ;;7045792
DIFGGSB2 ;;5150555

DINTEG2
DINTEG2 ;SFISC/dizSUM FILEMAN-FileMan checksum checker ;DEC 28, 1994@11:30:03
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIZ4="I 1" D DSP,INI
CONT F DIZ1=1:1 S DIZ2=$T(ROU+DIZ1) Q:DIZ2=""  S X=$P(DIZ2," ",1),DIZ3=$P(DIZ2,";",3) X DIZ4 I $T W !,X X DIZTEST W:'$T ?28,DIZ6 S:'$T DIZ3=0 X:DIZ3 DIZSUM W ?10,$S('DIZ3:"",DIZ3'=Y:$C(7)_"Calculated "_Y_", off by "_(Y-DIZ3),1:"ok")
 G CONT^DINTEG3
 S X="" F  S X=$O(^UTILITY($J,X)) Q:X=""  W !,X,?10,"not a routine in this INTEGRITY checker"
 K D,D1,D2,D3,X,Y,DIZ,DIZ1,DIZ2,DIZ3,DIZ4,DIZ5,DIZ6,DIZTEST,DIZSUM,DISYS,DIZSEL,^UTILITY($J) Q
ONE D INI S DIZSEL=$S($D(^%ZOSF("RSEL")):^("RSEL"),1:"F  S DIR(0)=""FO^1:8"",DIR(""A"")=""ROUTINE NAME"" D ^DIR Q:$D(DIRUT)  X DIZTEST W:'$T ?28,DIZ6 I $T S ^UTILITY($J,Y)=""""")
 S DIZ4="I $D(^UTILITY($J,X)) K ^(X)" D DSP
 W !,"Check a subset of routines:" K ^UTILITY($J) X DIZSEL
 W ! G CONT
DSP S X=$T(+2) W !!,"Checksum routine created on "_$P(X,";",6)_" by "_$P(X,";",4)_" V"_$P(X,";",3) Q
INI K ^UTILITY($J) D OS^DII S DIZTEST=$S($D(^DD("OS",DISYS,18)):^(18),1:"I $D(^ (X))"),DIZ5="",DIZ6=$C(7)_"Routine not in UCI"
 S DIZSUM="ZL @X S Y=0 F D=1,3:1 S D1=$T(+D),D3=$F(D1,"" "") Q:'D3  S D3=$S($E(D1,D3)'="";"":$L(D1),$E(D1,D3+1)="";"":$L(D1),1:D3-2) F D2=1:1:D3 S Y=$A(D1,D2)*D2+Y" Q
ROU ;;
DIFGGU ;;5525512
DIFGO ;;3849638
DIFGSRV ;;1145738
DIFROM ;;11038655
DIFROM0 ;;9100392
DIFROM1 ;;9679123
DIFROM11 ;;8986254
DIFROM12 ;;6395291
DIFROM2 ;;6822749
DIFROM3 ;;7863608
DIFROM4 ;;3939991
DIFROM41 ;;14320255
DIFROM42 ;;3811931
DIFROM5 ;;13318228
DIFROM6 ;;8014990
DIFROM7 ;;5693246
DIFROMH ;;8812360
DIFROMH1 ;;7701962
DIFROMS ;;1725573
DIFROMS1 ;;5768831
DIFROMS2 ;;6190772
DIFROMS3 ;;7300037
DIFROMS4 ;;4240259
DIFROMS5 ;;3415060
DIFROMS6 ;;868273
DIFROMSB ;;1316407
DIFROMSC ;;1542160
DIFROMSD ;;3803374
DIFROMSE ;;5059847
DIFROMSF ;;8096661
DIFROMSI ;;8134488
DIFROMSK ;;1421979
DIFROMSL ;;371524
DIFROMSO ;;1847867
DIFROMSP ;;6888702
DIFROMSR ;;4646734
DIFROMSS ;;3496020
DIFROMSU ;;5168157
DIFROMSV ;;89285
DIG ;;6265281
DIH ;;4688941
DII ;;6413260
DII1 ;;455555
DIINI001 ;;7758746
DIINI002 ;;7185246
DIINI003 ;;9033478
DIINI004 ;;7890739
DIINI005 ;;6512960
DIINI006 ;;8018142
DIINI007 ;;8798951
DIINI008 ;;7232119
DIINI009 ;;8236800
DIINI00A ;;4880814
DIINIS ;;2127703
DIINIT ;;10268911
DIINIT1 ;;4312623
DIINIT2 ;;5232051
DIINIT3 ;;16801795
DIINIT4 ;;3357221
DIINIT5 ;;364747
DIIS ;;374782
DIISS ;;2408793
DIK ;;7325945
DIK1 ;;5820262
DIKZ ;;9722227
DIKZ0 ;;5940541
DIKZ1 ;;8933794
DIKZ11 ;;4558086
DIKZ2 ;;5230837
DIL ;;6332887
DIL0 ;;5148814
DIL1 ;;6752508
DIL11 ;;5151125
DIL2 ;;9065502
DILF ;;1129307
DILFD ;;231253
DILIBF ;;6348908
DILL ;;6076491
DIM ;;2096545
DIM1 ;;7391479
DIM2 ;;4847408
DIM3 ;;4724114
DIM4 ;;3593321
DINIT ;;14307293
DINIT0 ;;5228258
DINIT001 ;;9222884
DINIT002 ;;9770143
DINIT003 ;;9283558
DINIT004 ;;7878368
DINIT005 ;;7116172
DINIT006 ;;7804999
DINIT007 ;;7371481
DINIT008 ;;7455825
DINIT009 ;;7710262
DINIT00A ;;7298150
DINIT00B ;;6817873
DINIT00C ;;7474896
DINIT00D ;;6215508
DINIT00E ;;6203285
DINIT00F ;;6944836
DINIT00G ;;6618387
DINIT00H ;;7525400
DINIT00I ;;7064051
DINIT00J ;;6340692
DINIT00K ;;6814146
DINIT00L ;;4996601
DINIT00M ;;4988352
DINIT00N ;;4358748
DINIT00O ;;5099250
DINIT00P ;;7094936
DINIT00Q ;;7854917
DINIT00R ;;6685186
DINIT00S ;;6285951
DINIT00T ;;6976234
DINIT00U ;;6454261
DINIT00V ;;10494647
DINIT00W ;;10423570
DINIT00X ;;7260573
DINIT00Y ;;6362756
DINIT00Z ;;7186746
DINIT010 ;;8406869
DINIT011 ;;8500074
DINIT012 ;;7486356
DINIT013 ;;6313482
DINIT014 ;;6116898
DINIT015 ;;5524998
DINIT016 ;;1335499
DINIT017 ;;8281492
DINIT018 ;;6764686
DINIT019 ;;3674630

DINTEG3
DINTEG3 ;SFISC/dizSUM FILEMAN-FileMan checksum checker ;DEC 28, 1994@11:30:03
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIZ4="I 1" D DSP,INI
CONT F DIZ1=1:1 S DIZ2=$T(ROU+DIZ1) Q:DIZ2=""  S X=$P(DIZ2," ",1),DIZ3=$P(DIZ2,";",3) X DIZ4 I $T W !,X X DIZTEST W:'$T ?28,DIZ6 S:'$T DIZ3=0 X:DIZ3 DIZSUM W ?10,$S('DIZ3:"",DIZ3'=Y:$C(7)_"Calculated "_Y_", off by "_(Y-DIZ3),1:"ok")
 G CONT^DINTEG4
 S X="" F  S X=$O(^UTILITY($J,X)) Q:X=""  W !,X,?10,"not a routine in this INTEGRITY checker"
 K D,D1,D2,D3,X,Y,DIZ,DIZ1,DIZ2,DIZ3,DIZ4,DIZ5,DIZ6,DIZTEST,DIZSUM,DISYS,DIZSEL,^UTILITY($J) Q
ONE D INI S DIZSEL=$S($D(^%ZOSF("RSEL")):^("RSEL"),1:"F  S DIR(0)=""FO^1:8"",DIR(""A"")=""ROUTINE NAME"" D ^DIR Q:$D(DIRUT)  X DIZTEST W:'$T ?28,DIZ6 I $T S ^UTILITY($J,Y)=""""")
 S DIZ4="I $D(^UTILITY($J,X)) K ^(X)" D DSP
 W !,"Check a subset of routines:" K ^UTILITY($J) X DIZSEL
 W ! G CONT
DSP S X=$T(+2) W !!,"Checksum routine created on "_$P(X,";",6)_" by "_$P(X,";",4)_" V"_$P(X,";",3) Q
INI K ^UTILITY($J) D OS^DII S DIZTEST=$S($D(^DD("OS",DISYS,18)):^(18),1:"I $D(^ (X))"),DIZ5="",DIZ6=$C(7)_"Routine not in UCI"
 S DIZSUM="ZL @X S Y=0 F D=1,3:1 S D1=$T(+D),D3=$F(D1,"" "") Q:'D3  S D3=$S($E(D1,D3)'="";"":$L(D1),$E(D1,D3+1)="";"":$L(D1),1:D3-2) F D2=1:1:D3 S Y=$A(D1,D2)*D2+Y" Q
ROU ;;
DINIT02 ;;2462683
DINIT03 ;;2421273
DINIT04 ;;3697957
DINIT05 ;;1825546
DINIT06 ;;1001974
DINIT07 ;;3740650
DINIT08 ;;7989773
DINIT0F0 ;;4401468
DINIT0F1 ;;2844141
DINIT0F2 ;;5669730
DINIT0F3 ;;6115371
DINIT0F4 ;;5916366
DINIT0F5 ;;4792287
DINIT0F6 ;;3822369
DINIT0F7 ;;3809021
DINIT0F8 ;;3681049
DINIT0F9 ;;2083336
DINIT1 ;;6609056
DINIT11 ;;7807097
DINIT11A ;;9392153
DINIT11B ;;3195420
DINIT11C ;;6005195
DINIT12 ;;9306353
DINIT120 ;;8317853
DINIT121 ;;10875848
DINIT122 ;;10992491
DINIT123 ;;11544691
DINIT124 ;;12338353
DINIT125 ;;10484654
DINIT126 ;;10127786
DINIT127 ;;8335195
DINIT13 ;;10341008
DINIT14 ;;3422144
DINIT2 ;;729944
DINIT20 ;;5340670
DINIT21 ;;3491420
DINIT22 ;;1548661
DINIT220 ;;487349
DINIT24 ;;11140614
DINIT25 ;;8381842
DINIT250 ;;4565635
DINIT255 ;;3074177
DINIT26 ;;7320579
DINIT260 ;;7558780
DINIT27 ;;8893587
DINIT270 ;;8954842
DINIT271 ;;4962636
DINIT27A ;;4535134
DINIT27B ;;3392667
DINIT27C ;;3010708
DINIT27D ;;3129310
DINIT27E ;;2362322
DINIT27F ;;7294806
DINIT27G ;;7287275
DINIT27H ;;991763
DINIT27I ;;1784973
DINIT27J ;;4891073
DINIT27K ;;4910854
DINIT27L ;;2952488
DINIT28 ;;2224020
DINIT285 ;;9217149
DINIT286 ;;2757795
DINIT287 ;;939077
DINIT290 ;;9040841
DINIT291 ;;8374884
DINIT292 ;;8869220
DINIT293 ;;11561311
DINIT294 ;;8359242
DINIT295 ;;10019078
DINIT296 ;;9334293
DINIT297 ;;1310471
DINIT298 ;;9267752
DINIT299 ;;11066049
DINIT29A ;;11649557
DINIT29B ;;9992422
DINIT29C ;;10380082
DINIT29D ;;8208281
DINIT29E ;;2998981
DINIT29P ;;1161392
DINIT3 ;;9096420
DINIT4 ;;9010496
DINIT41 ;;11669306
DINIT42 ;;8065804
DINIT5 ;;9581562
DINIT6 ;;3176942
DINITPST ;;118426
DINV1DTM ;;1497765
DINV1VXD ;;2343090
DINVDTM ;;6129007
DINVMSM ;;8405664
DINVVXD ;;6649372
DINZDTM ;;6206888
DINZMGR ;;8170762
DINZMGR1 ;;5426403
DINZMSM ;;3819112
DINZVXD ;;4163974
DIO ;;7212010
DIO0 ;;9337666
DIO1 ;;6789778
DIO2 ;;4090173
DIO3 ;;4969134
DIO4 ;;5969086
DIOC ;;906643
DIOQ ;;951380
DIOS ;;7207594
DIOS1 ;;1190642
DIOU ;;4893133
DIOZ ;;5699472
DIP ;;10842684
DIP0 ;;9017625
DIP1 ;;9630060
DIP10 ;;5485584
DIP11 ;;8098143
DIP12 ;;5158083
DIP2 ;;8015552
DIP21 ;;12550282
DIP22 ;;6639498
DIP23 ;;467210
DIP3 ;;10660874
DIP31 ;;1492535
DIP4 ;;2871248
DIP5 ;;9722926
DIPKI001 ;;8527821
DIPKI002 ;;8311211
DIPKI003 ;;10161905
DIPKI004 ;;11066884
DIPKI005 ;;9699423
DIPKI006 ;;7153468
DIPKI007 ;;8930731
DIPKI008 ;;8606961

DINTEG4
DINTEG4 ;SFISC/dizSUM FILEMAN-FileMan checksum checker ;DEC 28, 1994@11:30:03
 ;;21.0;VA FileMan;;Dec 28, 1994;
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIZ4="I 1" D DSP,INI
CONT F DIZ1=1:1 S DIZ2=$T(ROU+DIZ1) Q:DIZ2=""  S X=$P(DIZ2," ",1),DIZ3=$P(DIZ2,";",3) X DIZ4 I $T W !,X X DIZTEST W:'$T ?28,DIZ6 S:'$T DIZ3=0 X:DIZ3 DIZSUM W ?10,$S('DIZ3:"",DIZ3'=Y:$C(7)_"Calculated "_Y_", off by "_(Y-DIZ3),1:"ok")
 ;
 S X="" F  S X=$O(^UTILITY($J,X)) Q:X=""  W !,X,?10,"not a routine in this INTEGRITY checker"
 K D,D1,D2,D3,X,Y,DIZ,DIZ1,DIZ2,DIZ3,DIZ4,DIZ5,DIZ6,DIZTEST,DIZSUM,DISYS,DIZSEL,^UTILITY($J) Q
ONE D INI S DIZSEL=$S($D(^%ZOSF("RSEL")):^("RSEL"),1:"F  S DIR(0)=""FO^1:8"",DIR(""A"")=""ROUTINE NAME"" D ^DIR Q:$D(DIRUT)  X DIZTEST W:'$T ?28,DIZ6 I $T S ^UTILITY($J,Y)=""""")
 S DIZ4="I $D(^UTILITY($J,X)) K ^(X)" D DSP
 W !,"Check a subset of routines:" K ^UTILITY($J) X DIZSEL
 W ! G CONT
DSP S X=$T(+2) W !!,"Checksum routine created on "_$P(X,";",6)_" by "_$P(X,";",4)_" V"_$P(X,";",3) Q
INI K ^UTILITY($J) D OS^DII S DIZTEST=$S($D(^DD("OS",DISYS,18)):^(18),1:"I $D(^ (X))"),DIZ5="",DIZ6=$C(7)_"Routine not in UCI"
 S DIZSUM="ZL @X S Y=0 F D=1,3:1 S D1=$T(+D),D3=$F(D1,"" "") Q:'D3  S D3=$S($E(D1,D3)'="";"":$L(D1),$E(D1,D3+1)="";"":$L(D1),1:D3-2) F D2=1:1:D3 S Y=$A(D1,D2)*D2+Y" Q
ROU ;;
DIPKI009 ;;8334011
DIPKI00A ;;8305104
DIPKI00B ;;6001022
DIPKI00C ;;4378943
DIPKI00D ;;802177
DIPKI00E ;;3841062
DIPKINI1 ;;4282575
DIPKINI2 ;;5232585
DIPKINI3 ;;16806700
DIPKINI4 ;;3357757
DIPKINI5 ;;446749
DIPKINIS ;;2210516
DIPKINIT ;;10364554
DIPT ;;9127950
DIPZ ;;8349066
DIPZ0 ;;2495452
DIPZ1 ;;3058662
DIPZ2 ;;8696417
DIQ ;;6607325
DIQ1 ;;4398976
DIQG ;;11439696
DIQGDD ;;7426471
DIQGDD0 ;;1846736
DIQGDDT ;;7439422
DIQGDDU ;;1298733
DIQGQ ;;15365752
DIQGU ;;4906837
DIQGU0 ;;3019674
DIQQ ;;9990243
DIQQ1 ;;1235348
DIQQQ ;;5024310
DIR ;;8200401
DIR0 ;;5122108
DIR01 ;;4681732
DIR02 ;;2178268
DIR03 ;;4352430
DIR0H ;;2000761
DIR0K ;;1385205
DIR0W ;;3089175
DIR1 ;;7620389
DIR2 ;;8922361
DIR3 ;;3582829
DIRCR ;;3369745
DIRQ ;;968045
DIS ;;8071449
DIS0 ;;7360682
DIS1 ;;6004236
DIS2 ;;5717533
DIS3 ;;1548747
DIT ;;9006532
DIT0 ;;2588866
DIT1 ;;7324106
DIT2 ;;2621259
DIT3 ;;5880904
DITC ;;8730630
DITC0 ;;3191582
DITC1 ;;5739425
DITC2 ;;9411545
DITC3 ;;4586809
DITM ;;3764313
DITM1 ;;3291696
DITM2 ;;4300014
DITMGM1 ;;3241730
DITMGM2 ;;3998925
DITMGM2A ;;7225704
DITMGM2B ;;3795853
DITMGM2C ;;3479803
DITMGMRG ;;4234244
DITMGMRI ;;3560391
DITMU1 ;;267174
DITMU2 ;;1127015
DITMU3 ;;422892
DITMU4 ;;7174363
DITP ;;6552936
DITR ;;5643781
DITR1 ;;6414011
DIU ;;4034034
DIU0 ;;6188632
DIU1 ;;7395199
DIU2 ;;5805915
DIU21 ;;6146003
DIU3 ;;5768668
DIU31 ;;9874154
DIU4 ;;5389344
DIU5 ;;251900
DIV ;;3715836
DIVR ;;6095014
DIVRE ;;6418390
DIVRE1 ;;634136
DIWE ;;6067379
DIWE1 ;;6185993
DIWE11 ;;4308475
DIWE12 ;;5577760
DIWE2 ;;6639751
DIWE3 ;;8633894
DIWE4 ;;9748975
DIWE5 ;;8399507
DIWF ;;5538065
DIWP ;;5103576
DIWW ;;5725412
DIX ;;2522654
DIXC ;;4724715

DINV1DTM
%ZOSV1 ;SFISC/AC,LL/DFH,sfisc/fyb-View commands & special functions (continued) ;03:13 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DEVOPN ;X=$J,Y=List of devices separated by a comma
 N A,I,JA,JOB,DEV,CDEV,ODEV,PDEV
 S X=$J D JSTAT
 I 'ZVER S Y=$$jstat^%mjob(X),Y=$S($P(Y,"|",6)>0:$P(Y,"|",6)_",",1:"")_$P(Y,"|",9)_$E(",",$P(Y,"|",9)]"") Q
 S PDEV=$V(0,JA+18,-3),PDEV=$S(PDEV:$V(0,PDEV+2,-2),1:"-")
 S CDEV=$V(0,JA+22,-3),CDEV=$S(CDEV:$V(0,CDEV+2,-2),1:"-")
 S ODEV="",JOB=$V(0,JA+10,-4)
 ;S A=$V(1,62,-3) I A,$V(0,A+4,-2) D JDEV ; includes parents cur device
 S A=$V(1,38,-3)
 F A=A:0 Q:'$V(0,A,-2)  D:$V(0,A+4,-2)=JOB JDEV S A=A+$V(0,A,-2)
 S Y=$S(CDEV:CDEV_",",1:"")_$E(ODEV,2,999)_$E(",",$E(ODEV,2,999)]"")
 Q
JSTAT ; Get DTM data - X=Job Number
 S X=$S($D(X)[0:$J,X'?1N.N:$J,1:X)
 S ZVER=($P($ZVER,"/",2)'<4) ; ZVER=1 if Version 4
 S JA=$V(1,(X-1*2)+100,-2)*16
 Q
JDEV ;
 S DEV=$V(0,A+2,-2) I DEV,DEV'=PDEV S ODEV=ODEV_","_DEV
 Q
 ;
FREEDEV ;
 F P=$V($S($P($ZVER,"/",2)<4:4,1:1),38,-3):0 S L=$V(0,P,-2) Q:'L  Q:'$V(0,P+4,-2)&($V(0,P+6,-1)=6)  S P=P+L
 ;
 S IO=$S(L:$V(0,P+2,-2),1:"") Q
JOBLIST ; Active Jobs delimited by comma
 S Y=$$jobs^%mjob Q
 ;
SHUTDOWN ; Check shutdown flag
 S Y=$S($P($ZVER,"/",2)<4:$V(4,0,-1)#2,1:$V(1,0,-1)#2)
 Q

DINV1VXD
%ZOSV1 ;SFISC/AC-View commands & special functions(continued). ;03:11 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DEVOPN ;List devices opened.
 N %,%B,%I,%L,%X,%X1,%X2,%Y
 S %X1=$V($V(0)+8),%X2=$V(%X1),Y=""
 F %I=1:1 D D1 S %X2=$V(%X2) Q:%X2=%X1
 Q
D1 S %X=$V(%X2+8)
 S %L=$V(%X+4,-1,1),%B=$V(%X+8)
 S %Y=""
 F %=1:1:%L S %Y=%Y_$C($V(%B,-1,1)) S %B=%B+1
 S Y=Y_%Y_"," Q
 ;
DEVOK ;Check Device Availability.  (not complete)
 ;INPUT:  X=Device $I, X1=IOT -- X1 needed for resources
 ;OUTPUT: Y=0 if available, Y=job # if owned, Y=-1 if device does not exists.
 S Y=0 Q:X["::"  I $G(X1)="RES" G RES
 S Y=$ZC(%GETDVI,X,"EXISTS")
 G DV1:Y D DV2 Q:Y=-1  I Y="TERM" S Y=-1 Q
 S Y=-2 Q
DV1 S Y=$ZC(%GETDVI,X,"PID") I Y=$J!($ZC(%GETDVI,X,"SPL")) S Y=0 Q
 I Y,$ZC(%GETJPI,X,"MASTER_PID")=Y G DVOPN
 Q:Y>0  D DV2 G DVOPN:Y="TERM" S Y=$S(Y="DISK":0,Y="MAILBOX":0,Y="TAPE":0,1:-1) Q
DV2 S Y=$ZC(%PARSE,X) I Y="" S Y=-1 Q
 I X]"" S Y=$ZC(%GETDVI,$S(Y]"":Y,1:X),"DEVCLASS") Q
 Q
DVOPN S $ZT="DVERR",Y=0 Q:$D(%ZTIO)
 L:$D(%ZISLOCK) +@%ZISLOCK:60
 O X::$S($D(%ZISTO):%ZISTO,1:0) E  S Y=999 L:$D(%ZISLOCK) -@%ZISLOCK Q
 L:$D(%ZISLOCK) -@%ZISLOCK
 S Y=0 I '$D(%ZISCHK)!$S($D(%ZIS)#2:(%ZIS["T"),1:0) C X Q
 S:X]"" IO(1,X)="" Q
DVERR I $ZE["OPENERR" S Y=-1 Q
 ZQ
RES S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
 I '%ZISD0 S Y=-1,%ZISD0=%O(^%ZIS(1,"C",X)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
 S X1=$S($D(^%ZISL(3.54,+%ZISD0,0)):^(0),1:"")
 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
 K %ZISD0,%ZISD1
 Q

DINVDTM
%ZOSV ;SFISC/AC,LL/DFH,sfisc/fyb-View commands and special functions ;03:15 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; ** For DataTree **
 ;
ACTJ() ; Active Jobs
 Q $$njobs^%mjob("running")
 ;
AVJ() ; Available Jobs
 Q $$njobs^%mjob("free")
 ;
T0 ; start RT clock
 S XRT0=$H Q
T1 ; store RT datum
 S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0 Q
MAXJ ; Maximum # of Jobs
 S Y=$$njobs^%mjob("total") Q
 ;
BAUD ; Baud rate of device - used by BAUD field of the Device File
 ; Internal entry of device is D0
 ;ZETRAP BAUDERR
 ;S X=$zdevspeed($P(^%ZIS(1,D0,0),"^",2)) Q
BAUDERR ;S X="" Q
 Q
 ;
LGR() Q $ZR ;Last global reference
 ;
EC() Q $ZE ;Error code
 ;
DEVOPN ;X=$J,Y=List of devices separated by a comma
 G DEVOPN^%ZOSV1
 ;
DEVOK ;X=Device $I, Y=0 if available, Y=999 if device is busy
 ;Y=-1 if device is undefined.
 G RES:$G(X1)="RES" I $E(X)="/"!($E(X)="\") S Y=0 Q
 I $D(X)[0 S X=$I
 I X=$I S Y=$J Q
 I X<20,(X>9) S Y=0 D NULLDEV O X:("W":NULLDEV):0 C:$T X S:'$T Y=999 Q
 ZETRAP NODEV
 L:$D(%ZISLOCK) +@%ZISLOCK:60
 O X::0 I '$T S Y=999 L:$D(%ZISLOCK) -@%ZISLOCK Q
 L:$D(%ZISLOCK) -@%ZISLOCK
 C X S Y=0
 Q
RES S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
 I '%ZISD0 S Y=-1,%ZISD0=%O(^%ZIS(1,"C",X)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
 S X1=$S($D(^%ZISL(3.54,+%ZISD0,0)):^(0),1:"")
 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
 K %ZISD0,%ZISD1
 Q
NULLDEV ; based on %device
 K HWTYPE S NULLDEV="NUL",H=$V($S($P($ZVER,"/",2)<4:4,1:1),3,-1)
 S HWTYPE=$S(H<10:"WS",H<20:"MF",H<64:"?",H<129:"PC",1:"?")
 I HWTYPE'="PC" S NULLDEV="[NUL]"
 K H,HWTYPE Q
 ;
NODEV S Y=-1
 Q
 ;
DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
 ;I $P($ZVER,"/",2)<4 D ^%VARLOG
 S Y="%" F %=0:0 S Y=$O(@Y) Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 Q
 ;
ORDER ; Save part of the symbol table in location specified by X
 S (Y,Y1)=$P(Y,"*",1) I $D(@Y)=0 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y[Y1)
 Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y)
 I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y'[Y1)  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 K %,X,Y,Y1 Q
 ;
JOBPAR ; Returns job X's namespace
 D JSTAT^%ZOSV1
 I ($P($ZVER,"/",2)'<4)&($P($ZVER,"/",2)<4.3) S Y=$ZCONVERT($V(0,JA+908,-5),"U")
 E  S Y=$$jstat^%mjob(X),Y=$P(Y,"|",4)
 Q
 ;
 ;
NOLOG ; No logins allowed
 S Y=0 Q
 ;
PARSIZ ;
 S X=3 Q
 ;
PRIINQ() ; Priority Inquire
 N X,Y S X=$J D JSTAT^%ZOSV1
 I ZVER S Y=$V(0,$V(1,(X-1*2)+100,-2)*16+5,-1)-128\2 S:Y Y=10-Y
 E  S Y=$$jstat^%mjob(X),Y=$P(Y,"|",7) S:Y Y=10-Y
 Q Y
 ;
PRIORITY ; Set priority of job
 I X<1!(X>10) Q
 S Y=X,X=10-X ; convert Kernel to DTM priority
 I $P($ZVER,"/",2)<4 V 64+$J:50:$C(128+X) Q
 S X=X*2+128 zc #changepriority(X) V 2:5:$C(X)
 Q
PRGMODE ;
 W ! S ZTPAC=$S($D(^VA(200,+DUZ,.1))#10:$P(^(.1),"^",5),1:""),XUVOL=^%ZOSF("VOL")
 I ZTPAC]"" X ^%ZOSF("EOFF") R !,"PAC: ",X:60 S X=$ZCONVERT(X,"U") X ^%ZOSF("EON") I X'=ZTPAC W "??",*7 Q
 I $D(^XMB(3.7,0)),$D(DUZ)#2 S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$D(^XMB(3.7,0)) K ^XMB(3.7,DUZ,100,$I),^XUSEC(0,"CUR",DUZ,+^XUTL("XQ",$J,0))
 K ZTPAC,X,XMB
 X ^%ZOSF("UCI") S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI
 U:$I>99 $I:IXXLATE=2 D ^%mshell
 ;
UCICHECK(X) ; The call to ns^%m for Version 4 is necessary
 ; only if namespaces are password protected.
 ZETRAP BADUCI N CURUCI
 S X=$P(X,",")
 S X=$ZCONVERT(X,"U"),CURUCI=$ZNSPACE
 I $P($ZVER,"/",2)<4 ZNSPACE X ZNSPACE CURUCI Q X
 D ns^%m(X,1) S ^UTILITY($J)="" ; *** force error if dataset not mounted
 I CURUCI'=X D ns^%m(CURUCI,1)
 Q X
BADUCI ; set flag and return to old namespace
 S Y=0
 I $P($ZVER,"/",2)<4 ZNSPACE CURUCI
 E  D ns^%m(CURUCI,1)
 Q Y
 ;
SETENV ; Set environment
 S XUENV=X_"^"
 I $P($ZVER,"/",2)>4.2 V 2:374:$C($L(X))_X:$J#256 Q
 S X1=X,X=$J D JSTAT^%ZOSV1
 V 0:JA+374:$C($L(X1))_X1
 Q
GETENV ; Get environment
 S Y=$ZNSPACE_"^"_^%ZOSF("VOL")_"^^"_^%ZOSF("VOL")
 Q
TRMON ;Turn terminators on
 U $I:IXINTERP=2 N % S %=$$getall^%mixinterp()
 I $A(%)'=35 F %=0:1:31,127 D set^%mixinterp(%,35)
 Q
TRMOFF ;Turn terminators off
 U $I:IXINTERP=$S($I>99:1,1:0)
 Q
PASSALL ;Pass all characters
 U $I:IXINTERP=3 N % S %=$$getall^%mixinterp()
 I $A(%)'=18 F %=0:1:31,127 D set^%mixinterp(%,18)
 Q
NOPASS ;Do not pass all characters
 D TRMOFF
 Q
 ;
HFSREW(IO,IOPAR) ;Rewind Host File
 S $ZT="HFSRWERR"
 U IO:(LFA=0)
 Q 1
HFSRWERR ;Error encountered.
 Q 0
LOGRSRC(OPT) ;record resource usage in ^XUCP
 Q
SETTRM(X) ;Turn on specified terminators.
 U $I:TERM=X
 Q 1

DINVMSM
%ZOSV ;SFISC/AC-$View commands for MSM-UNIX ;03:16 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ACTJ() ;
 Q $S($$V3:$V($V(44)+168,-3,2),1:$V(168,-4,2))
AVJ() ;
 Q $S($$V3:$V($V(44)+94,-3,2)+1-$V($V(44)+168,-3,2),1:$V($V(3,-5),-3,0)-$V(168,-4,2))
T0 ; start RT clock
 S XRT0=$H Q
T1 ; store RT datum
 S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0 Q
JOBPAR ;
 S Y=$V(2,X,2) Q:'Y
 S Y=$ZU(Y#32,Y\32) Q
PROGMODE() ;
 Q $V(0,$J,2)#2
PRGMODE ;
 W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL")
 ;I ZTPAC="" W *7,"YOU HAVE NO PROGRAMMER ACCESS CODE!",! Q
 I ZTPAC]"" X ^%ZOSF("EOFF") R !,"PAC: ",X:60 X ^%ZOSF("EON") I X'=ZTPAC W "??",*7 Q
 S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$D(^XMB(3.7,0)) K ^XMB(3.7,+DUZ,100,$I),^XUSEC(0,"CUR",DUZ,+^XUTL("XQ",$J,0)),ZTPAC,X,XMB
 S ZOSVER='$ZB($V(140,$J,2),512,1) ; 1 if V 2.1+ err trapping in effect
 X ^%ZOSF("UCI") S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI B:ZOSVER 2 V 0:$J:$ZB($V(0,$J,2),1,7):2 S $ZE="PRGMODEX^%ZOSV" ABORT
PRGMODEX W !,"YOU ARE NOW IN PROGRAMMING MODE!",! S $ZE="" B:ZOSVER -2 K ZOSVER Q
 ;
SIGNOFF ;
 I 0
 ;I $V($V(44)+4,-3,2)\32768#2 Q
UCI ;
 S Y=$ZU(0) Q  ;X ^%ZOSF("UCI") Q
 ;
UCICHECK(X) ;
 N Y,I S Y="",$ZT="BADUCI^%ZOSV"
 I X["," S Y=$ZU($P(X,","),$P(X,",",2)),(X,Y)=$ZU($P(Y,","),$P(Y,",",2)) Q:Y]"" Y
 F I=1:1:64 G:$ZU(I)="" BADUCI Q:$ZU(I)=X!($P($ZU(I),",")=X)!(I=X)
 Q $ZU(I)
 ;
BADUCI Q ""
 ;
BAUD ;S Y=^%ZOSF("MGR"),X=$S($D(^%ZIS(1,D0,0)):$P(^(0),"^",2),1:"")
 ;Q:X=""  I '$D(^[Y]SYS(0,"DDB",+X)) S X="" Q
 ;S X=$P(^(+X),",",3)#100 Q:'X
 ;S X=$P("50,75,110,134.5,150,300,600,1200,1800,2400,3600,4800,9600",",",X) Q
 Q
 ;
LGR() Q $ZR ;Last global ref.
 ;
EC() Q $ZE ;Error code
 ;
DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
 S Y="%" F %=0:0 S Y=$O(@Y) Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 Q
 ;
ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
 S (Y,Y1)=$P(Y,"*",1) I $D(@Y)=0 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y[Y1)
 Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y'[Y1)  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 K %,X,Y,Y1 Q
 ;
PRIORITY ;
 N %D,%P S %P=(X>5) D INT^%HL Q
 ;
PRIINQ() ;
 Q $S($V(20,$J,2):10,1:1)
PARSIZ ;
 S X=3 Q
 ;
NOLOG ;
 S Y=$S($$V3:"$V($V(44)+4,-3,2)",1:"$V(4,-4,2)")_"\64#2" Q
 ;
DEVOPN ;
 ;X=$J,Y=List of devices separated by a comma
 N %,%1,%I,%X
 S Y=""
 I $$V3 S %=$V($V(44)+10,-3,2),%1=$V($V(44)+8,-3,2)+$V(44),%=$V(%*5+%1)
 E  S %=$V(5,-5,0)
 F %I=1:1:255 S %X=$V(%+%I+%I,-3,2) I %X,%X#4=0,%X/4=X S Y=Y_%I_","
 Q
DEVOK ;
 ;X=Device $I, Y=0 if available, Y=Job # if owned,
 ;Y=-1 if device is undefined.
 G RES:$G(X1)="RES" I $E(X)="/"!($E(X)="\") S Y=0 Q
 I X=2 S Y=0 Q
 I X'?1.N!(X'>0!(X'<1024)) S Y=-1 Q
 N %
 I $$V3 S %=$V($V(44)+8,-3,2)+$V(44),%=$V($V($V(44)+10,-3,2)*5+%),Y=$V(%+X+X,-3,2),Y=$S(Y=0:0,Y#4=0:Y/4,1:-1)
 E  S %=$V(5,-5,0),Y=$V(%+X+X,-3,2),Y=$S(Y=0:0,Y#4=0:Y/4+$V(272,-4),1:-1)
 I 'Y D DVOPN Q
 S:Y=$J Y=0 Q
DVOPN S $ZT="DVERR",Y=0 Q:$D(%ZTIO)
 L:$D(%ZISLOCK) +@%ZISLOCK:60
 O X::$S($D(%ZISTO):%ZISTO,1:0) E  S Y=999 L:$D(%ZISLOCK) -@%ZISLOCK Q
 L:$D(%ZISLOCK) -@%ZISLOCK
 S Y=0 I '$D(%ZISCHK)!$S($D(%ZIS)#2:(%ZIS["T"),1:0) C X Q
 S:X]"" IO(1,X)="" Q
DVERR I $ZE["OPENERR" S Y=-1 Q
 ZQ
RES S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0))
 I '%ZISD0 S Y=-1,%ZISD0=%O(^%ZIS(1,"C",X)) Q:'%ZISD0  Q:'$D(^%ZIS(1,+%ZISD0,0))  Q:$P(^(0),"^")'=X  Q:'$D(^("TYPE"))  Q:^("TYPE")'="RES"  S Y=0 Q
 S X1=$S($D(^%ZISL(3.54,+%ZISD0,0)):^(0),1:"")
 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q
 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0  I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q
 K %ZISD0,%ZISD1
 Q
V2CL1 F %=0:0 Q:$ZA<0  R %X:5 Q:%X']""  F %1=0:0 S %1=$L(%Y),%Y=%Y_$E(%X,1,255-%1),%X=$E(%X,256-%1,$L(%X)),%1=$F(%Y,%ZCR) Q:%1'>0  S %2=$E(%Y,$A(%Y)=10+1,%1-2),%Y=$E(%Y,%1,$L(%Y)) D V2CL2
 C 2:256 K IO(1,2) D CLOSE^ZISPL1 K %Y,%X,%1,ZOSFV
 Q
V2CL2 S %1=$F(%2,$C(12)) I %1>0 S %=%+1 D LIMIT:%Z1<% Q:%Z1<%  S ^XMBS(3.519,XS,2,%,0)="|TOP|",%2=$E(%2,1,%1-2)_$E(%2,%1,$L(%2))
 S %=%+1,^XMBS(3.519,XS,2,%,0)=%2 Q
 ;
LIMIT S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT  -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
 ;
SET ;SET SPECIAL VARIABLES
 S X=$H X ^%ZOSF("ZD") S DT=$E(Y,7,8)+200_$E(Y,1,2)_$E(Y,4,5)
 Q
GETENV ;Get enviroment  (UCI^VOL^NODE)
 S Y=$P($ZU(0),",",1)_"^"_$P($ZU(0),",",2)_"^^"_$P($ZU(0),",",2) Q
SETENV ;Set enviroment
 Q
LOGRSRC(OPT) ;record resource usage in ^XUCP
 Q
V3() ;returns 1=version 3, 0=version 4
 Q $P($ZV,"Version ",2)<4
SETTRM(X) ;Set specified terminators.
 U $I:(::::::::X)
 Q 1

DINVVXD
%ZOSV ;SFISC/AC-View commands & special functions. ;03:29 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ACTJ() ; # active jobs
 Q $P($$JOBS^%SY,",",2)
 ;
AVJ() ; # available jobs
 N Y S Y=$$JOBS^%SY Q +Y-$P(Y,",",2)
 ;
T0 ; start RT clock
 S %ZH0=$ZH,%=$P(%ZH0,",",3) S:$E($ZV,10,12)>5.1 %=$E(%,13,23) S XRT0=+$H_","_($P(%,":")*3600+($P(%,":",2)*60)+$P(%,":",3)) Q
 ;
T1 ; store RT datum w/ZHDIF
 S %ZH1=$ZH,%=$P(%ZH1,",",3) S:$E($ZV,10,12)>5.1 %=$E(%,13,23) S XRT1=+$H_","_($P(%,":")*3600+($P(%,":",2)*60)+$P(%,":",3))
 S ^%ZRTL(3,XRTL,+XRT1,XRTN,$P(XRT1,",",2))=XRT0_"^^"_($P(%ZH1,",")-$P(%ZH0,","))_"^"_($P(%ZH1,",",7)-$P(%ZH0,",",7))_"^"_($P(%ZH1,",",8)-$P(%ZH0,",",8)) K XRT0,%ZH0,%ZH1 Q
 ;
PASSALL ;
 S Y=$ZC(%SPAWN,"SET TERM/PASTHRU "_$I) U $I:NOTERM Q
NOPASS ;
 S Y=$ZC(%SPAWN,"SET TERM/NOPASTHRU "_$I) U $I:TERM="" Q
 ;
PRGMODE ;
 W ! S ZTPAC=$S($D(^VA(200,+DUZ,.1))#10:$P(^(.1),"^",5),1:""),XUVOL=^%ZOSF("VOL")
 S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??",*7 Q
 S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$D(^XMB(3.7,0)) K ^XMB(3.7,+DUZ,100,$I),^XUSEC(0,"CUR",DUZ,+^XUTL("XQ",$J,0)),ZTPAC,X,XMB
 I '$$PROGMODE() D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI ZESCAPE
 E  S $ECODE=",<<PROG>>,"
 ;
PROGMODE() ;
 Q ($V($V($V(0)))#2=0)
 ;
UCI ;
 S Y=$ZC(%UCI),Y=$P(Y,",",1)_","_$P(Y,",",4) Q
 ;
UCICHECK(X) ;
 N %,%1,U,V,Y
 I '(X?3U!(X?3U1","3U)) Q ""
 S U=$ZC(%UCI),V=$P(U,",",4),U=$P(U,","),%1=$P(X,",",2),%=$P(X,",")
 S Y=$ZC(%SETUCI,%,%1),Y=$S(Y:%_","_$S(%1]"":%1,1:V),1:""),V=$ZC(%SETUCI,U,V)
 Q Y
 ;
PRIORITY ;
 Q:X>10!(X<1)  S X=(X+1)\2-1,Y=$ZC(%SETPRI,X) Q
 ;
PRIINQ() ;
 Q $ZC(%GETJPI,0,"PRIB")*2+2
 ;
BAUD ;S X="UNKNOWN" Q
 Q
 ;
LGR() Q $ZR ;Last global ref.
 ;
EC() Q $ZE ;Error code
 ;
DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
 S Y="%" F  S Y=$ZSORT(@Y) Q:Y=""  D  ;code from DEC
 . I $D(@Y)#2 S @(X_"Y)="_Y)
 . I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 K %X,%Y,Y Q
 ;
ORDER ;SAVE PARTS OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
 ;PARTS INDICATED BY X1("NAMESPACE*")="" ARRAY
 I $D(X1("*"))#2 D DOLRO Q
 S X1="" F  S X1=$O(X1(X1)) Q:X1=""  D
 . S (Y,Y1)=$P(X1,"*") I $D(@Y)=0 F  S Y=$ZSORT(@Y) Q:Y=""!(Y[Y1)
 . Q:Y=""  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 . F  S Y=$ZSORT(@Y) Q:Y=""!(Y'[Y1)  S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
 . Q
 K %,%X,%Y,Y,Y1 Q
 ;
PARSIZ ;
 S X=3 Q
 ;
NOLOG ;
 S Y=0 Q
 ;
DEVOPN G DEVOPN^%ZOSV1
DEVOK G DEVOK^%ZOSV1
RES G RES^%ZOSV1
 ;
GETENV ;Get environment Return Y='UCI^VOL/DIR^NODE^BOX LOOKUP'
 S Y=$P($ZU(0),",",1)_"^"_$P($ZU(0),",",2)_"^"_$P($ZC(%GETSYI),",",4)
 S $P(Y,"^",4)=$P(Y,"^",2)_":"_$P(Y,"^",3) Q
SETENV ;Set environment X='PROCESS NAME^ '
 S %=$ZC(%SETPRN,$P(X,"^")) Q
 ;
ZHDIF ;Display dif of two $ZH's
 W !," CPU=",$J($P(%ZH1,",")-$P(%ZH0,","),6,2),?14," ET=",$J($P(%ZH1,",",2)-$P(%ZH0,",",2),6,1),?27," DIO=",$J($P(%ZH1,",",7)-$P(%ZH0,",",7),5),?40," BIO=",$J($P(%ZH1,",",8)-$P(%ZH0,",",8),5),! Q
LOGRSRC(OPT) ;record resource usage in ^XUCP
 N C,H,U S C=",",U="^",%=$ZH,H=$P(%,C,3) S:$E($ZV,10,12)>5.1 H=$E(H,13,23) S H=$P($H,C)_C_($P(H,":")*3600+($P(H,":",2)*60)+$P(H,":",3))
 S ^XUCP($P($ZC(%GETSYI),C,4),$P(H,C),$J,$P(H,C,2))=$P(%,C)_U_$P(%,C,7)_U_$P(%,C,8)_U_$P(%,C,4)_U_OPT_U_$P(%,C,3) Q
 ;
SETTRM(X) ;Turn on specified terminators.
 U $I:TERM=X
 Q 1

DINZDTM
DINZDTM ;SFISC/HGL,AL-SETS %ZOSF FOR DATATREE ;03:23 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
 F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z=""  S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=X
 K I,X,Z
 Q
V3 ;
 S ^%ZOSF("TRAP")="$ZE=X"
 S ^%ZOSF("PROGMODE")="S Y=0"
 Q
Z ;;
 ;;OS;; Operating System Name
 ;;DTM-PC^9
 ;;ACTJ;; Active Jobs
 ;;S Y=$$ACTJ^%ZOSV
 ;;AVJ;; Available Jobs
 ;;S Y=$$AVJ^%ZOSV
 ;;MAXJ;; Maximum # of Jobs
 ;;G MAXJ^%ZOSV
 ;;BRK;; Enable Break
 ;;B 1
 ;;DEL;; Delete Routine in X
 ;;zdelete @X:1
 ;;EOFF;; Turn echo off
 ;;U $I:(echom=0)
 ;;EON;; Turn echo on
 ;;U $I:(echom=1)
 ;;EOT;; End of tape
 ;;S Y=($ZIOS=3)
 ;;ERRTN;; Error trap routine
 ;;^%ZTER
 ;;ETRP;; Set error trap to X
 ;;Q
 ;;GD;; Global Directory
 ;;G ^%gd
 ;;JOBPARAM
 ;;G JOBPAR^%ZOSV
 ;;LABOFF
 ;;U IO:(echom=0)
 ;;LOAD
 ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
 ;;LPC;;
 ;;S Y=$ZCRC(X,1)
 ;;MAXSIZ;; Reset partition size
 ;;Q
 ;;NBRK;; Disable Break
 ;;B 0
 ;;NO-PASSALL
 ;;G NOPASS^%ZOSV
 ;;NO-TYPE-AHEAD;; Turn off type-ahead
 ;;U $I:(ta=0)
 ;;PARSIZ
 ;;S X=3
 ;;PASSALL
 ;;G PASSALL^%ZOSV
 ;;PRIINQ;; Find job's priority
 ;;S Y=$$PRIINQ^%ZOSV()
 ;;PRIORITY;; Set a job's priority
 ;;G PRIORITY^%ZOSV
 ;;PROGMODE;; Check if user is in programmer mode
 ;;S Y=$ZMODE
 ;;RD;; Routine Directory
 ;;G ^%rd
 ;;RESJOB
 ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^%mjob[MGR]" D DO^%XUCI
 ;;RM;; Set right margin to X ;***EDITED BY AC/SFISC***
 ;;U $I:(lmar=0:width=$S(X:X,1:$zdevfwid):wrap=(X&($I>99)))
 ;;RSEL;; Routine Select - returns number of routines in NRO
 ;;K ^UTILITY($J) S NRO=$$^%rselect W !,NRO," routines selected" S %X="^%RSET("_$J_",",%Y="^UTILITY("_$J_"," D %XY^%RCR S ^UTILITY($J)=^%RSET($J) K ^%RSET($J),%X,%Y
 ;;RSUM
 ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
 ;;SAVE
 ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  S:%'[$C(9) %=$P(%,"" "",1)_$C(9)_$P(%,"" "",2,999) I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS
 ;;SIZE;; Return size of routine in partition
 ;;S Y=$L($zrsource($zn))
 ;;SS;; System Status
 ;;G ^%mjob
 ;;TEST;; Routine existence test
 ;;I $ZRSTATUS(X)'=""
 ;;TMK;; Tapemark
 ;;Q
 ;;TRMOFF
 ;;G:$P($ZVER,"/",2)<4.3 TRMOFF^%ZOSV U $I:TERM=$C(13,27)
 ;;TRMON
 ;;G:$P($ZVER,"/",2)<4.3 TRMON^%ZOSV U $I:TERM=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)
 ;;TRMRD
 ;;S Y=$S('$ZIOS:$ZIOT,1:0)
 ;;TRAP;; DTM V4 only.  zetrap works for both versions
 ;;$ZT=X
 ;;TYPE-AHEAD;; Turn on type-ahead
 ;;U $I:(ta=1)
 ;;UCI;; Return current namespace in Y
 ;;S Y=$ZNSPACE
 ;;UCICHECK;;
 ;;S Y=$$UCICHECK^%ZOSV(X)
 ;;UPPERCASE
 ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;;XY;; Position cursor
 ;;S $X=DX,$Y=DY
 ;;ZD;; External date format in Y
 ;;S Y=$ZD($H,1)

DINZMGR
DINZMGR ;SFISC/MKO-TO SET UP THE MGR ACCOUNT FOR THE SYSTEM ;08:32 AM  28 Sep 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;This is a modification of Kernel's ZTMGRSET routine.
 I $D(^%ZTSK),$D(^%ZOSF("MGR"))#2 D  Q
 . W !,$C(7)_"  The VA Kernel appears to be installed on the system."
 . W !,"  ^DINZMGR should only be used during a stand-alone VA FileMan installation.",!
 ;
 S U="^"
 D INTRO^DINZMGR1
 ;
 K DIR
 S DIR("A",1)="Do you wish to proceed"
 S DIR("B")="YES"
 S DIR("?",1)="Enter 'Y' to continue.  Enter 'N' or '^' to quit."
 D DIR K DIR G:$D(DIQUIT)!'Y Q
 ;
 D ZS G:$D(DIQUIT)!'Y Q
 D OS^DINZMGR1 G:$D(DIQUIT) Q
 ;
 I $D(^%ZOSF("UCI")) X ^("UCI") I Y'["MG" D  G:$D(DIQUIT)!'Y Q
 . K DIR
 . S DIR("A",1)="THIS MAY NOT BE THE MANAGER UCI."
 . S DIR("A",2)="I think it is "_Y_".  Should I continue anyway"
 . S DIR("B")="NO"
 . S DIR("?",1)="This routine will attempt to file some % routines and set nodes"
 . S DIR("?",2)="in the %ZOSF global.  It should therefore be run in the manager"
 . S DIR("?",3)="account."
 . D DIR K DIR
 ;
 D DT G:$D(DIQUIT) Q
 D ZIS G:$D(DIQUIT) Q
 D ZISS G:$D(DIQUIT) Q
 D ZOSF G:$D(DIQUIT) Q
 W !!,"ALL DONE",!
 G Q
 ;
ZS K DIR
 S DIR("A",1)="Are the ZLOAD and ZSAVE commands implemented"
 S DIR("A",2)="on your MUMPS operating system (Y/N)"
 S DIR("?",1)="Since this utility will use ZLOAD and ZSAVE to file some routines"
 S DIR("?",2)="under different names, you can use this utility only if those"
 S DIR("?",3)="commands are available.  Otherwise, you'll have to perform the"
 S DIR("?",4)="operations manually."
 D DIR K DIR Q:$D(DIQUIT)
 Q
DT K DIR
 S DIR("A",1)="Do you want to save DIDT, DIDTC, and DIRCR"
 S DIR("A",2)="as %DT, %DTC, and %RCR"
 S DIR("B")="YES"
 S DIR("?",1)="Enter 'YES' to refile the routines.  This step must be performed",DIR("?",2)="in order for FileMan to work properly."
 D DIR K DIR Q:$D(DIQUIT)!'Y
 W ! S %S="DIDT^DIDTC^DIRCR",%D="%DT^%DTC^%RCR" D MOVE
 Q
ZIS K DIR
 S DIR("A",1)="Do you want to save DIIS as %ZIS (Y/N)"
 S DIR("?",1)="Enter 'YES' if you want to save the FileMan-supplied DIIS routine",DIR("?",2)="as %ZIS."
 D DIR K DIR Q:$D(DIQUIT)!'Y
 W ! S %S="DIIS",%D="%ZIS" D MOVE
 Q
ZISS K DIR
 S DIR("A",1)="Do you want to save DIISS as %ZISS (Y/N)"
 S DIR("?",1)="Enter 'YES' if you want to save the FileMan-supplied DIISS routine",DIR("?",2)="as %ZISS."
 D DIR K DIR Q:$D(DIQUIT)!'Y
 W ! S %S="DIISS",%D="%ZISS" D MOVE
 Q
ZOSF S DIR("A",1)="Do you want me to set nodes in the ^%ZOSF global and"
 S DIR("A",2)="to file the %ZOSV routine (and possibly the %ZOSV1 routine)"
 S DIR("A",3)="appropriate for the MUMPS operating system you are using (Y/N)"
 S DIR("?",1)="FileMan's screen-oriented utilities require certain %ZOSF nodes"
 S DIR("?",2)="to be present.  Some of these nodes call %ZOSV and %ZOSV1,"
 S DIR("?",3)="so those routines must also be present."
 D DIR K DIR S:'Y DIQUIT=1 Q:$D(DIQUIT)
 W ! S %D="%ZOSV" D @DIOS
 Q
1 ;M/11
 ;S %S="DINVM11" D MOVE
 ;D ^DINZM11
 Q
2 ;M/SQL-PDP
 ;S %S="DINVM11P" D MOVE
 ;D ^DINZM11P
 Q
3 ;M/SQL;was M/SQL-VAX
 W !?3,$C(7)_"M/SQL is not yet supported."
 ;S %S="DINVMVX" D MOVE
 ;D ^DINZMVX
 Q
4 ;DSM-4
 ;S %S="DINVDSM" D MOVE
 ;D ^DINZDSM
 Q
5 ;DSM for OpenVMS;was VAX DSM(V6)
 S %S="DINVVXD" D MOVE
 S %S="DINV1VXD",%D="%ZOSV1" D MOVE
 D ^DINZVXD
 Q
6 ;MSM
 S %S="DINVMSM" D MOVE
 D ^DINZMSM
 Q
7 ;DTM-PC
 S %S="DINVDTM" D MOVE
 S %S="DINV1DTM",%D="%ZOSV1" D MOVE
 D ^DINZDTM
 Q
8 ;GT.M(VAX)
 W !?3,$C(7)_"GT.M(VAX) is not yet supported."
 ;S %S="DINVGTM" D MOVE
 ;S %S="DINV1GTM",%D="%ZOSV1" D MOVE
 ;D ^DINZGTM
 Q
 ;
MOVE F %=1:1:$L(%D,U) S X=$P(%S,U,%),Y=$P(%D,U,%) I X]"",Y]"" W !,"Loading ",X X "ZL @X ZS @Y" W ?20,"Saved as ",Y
 K %S,%D
 Q
Q K %,X,X1,Y,DIOS,DIQUIT,DISAVE
 Q
DIR K DIQUIT S Y=0 W ! F %=1:1 Q:'$D(DIR("A",%))  W !,DIR("A",%)
 W "? "_$S($D(DIR("B")):DIR("B")_"// ",1:"")
 R X:300 S:X="" X=$S($D(DIR("B")):DIR("B"),1:"NULL")
 I X[U!'$T S DIQUIT=1 Q
 I $P("NO",$TR(X,"no","NO"))="" S Y=0 Q
 I $P("YES",$TR(X,"yes","YES"))="" S Y=1 Q
 I X?1."?",$D(DIR("?")) D  G DIR
 . W ! F %=1:1 Q:'$D(DIR("?",%))  W !?5,DIR("?",%)
 W $C(7),!!?5,"Enter 'YES' or 'NO', or '^' to quit." G DIR
 Q

DINZMGR1
DINZMGR1 ;SFISC/MKO-TO SET UP THE MGR ACCOUNT FOR THE SYSTEM ;9/8/94  13:00
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
INTRO ;Print introductory text
 W !!!,"HELLO!"
 W !!,"I exist to assist you in correctly initializing the manager account",!,"or to update the current account."
 W !!,"I'm going to do the following:"
 W !!?3,"1.  File the routines DIDT, DIDTC, and DIRCR as %DT, %DTC, and",!?7,"%RCR, respectively."
 W !!?3,"2.  File the routines DIIS and DIISS as %ZIS and %ZISS, respectively."
 W !!?3,"3.  Set nodes in the %ZOSF global.  This global contains"
 W !?7,"MUMPS operating system-specific code required by FileMan's"
 W !?7,"screen-oriented utilities."
 W !!,?3,"4.  Save a %ZOSV routine (and possibly a %ZOSV1 routine) specific",!?7,"to your MUMPS operating system."
 W !!,"Note that on some MUMPS systems, executing some of the ^%ZOSF nodes"
 W !,"causes ^XUTL global nodes to be set in the production account."
 Q
 ;
OS ;Prompt for operating system
 N I,J
 S Y=0
 I $D(^%ZOSF("OS"))#2 D
 . S X1=$P(^%ZOSF("OS"),U),Y=$P(^("OS"),U,2)
 . S:Y=7 X1="M\SQL",Y=18
 . I X1=""!'Y S (X1,Y)="" Q
 . W !!,"I think you are using "_X1
 . S Y=$S(Y=1:1,Y=13:2,Y=18:3,Y=2:4,Y=16:5,Y=8:6,Y=9:7,Y=17:8,1:0)
 ;
OS1 W !!,"Which MUMPS system are you using?",!
 F I=1:1 S J=$P($T(@I),";;",2,999) Q:J=""  D
 . W !
 . W:$P(J,";",2)]"" ?3,$P(J,";",2)
 . W ?5,I_" = "_$P(J,";")
 W !!?9,"* No longer supported."
 W !!,"MUMPS System: " W:Y Y,"// " R X:300 S:X="" X=Y
 I X[U!'$T S DIQUIT=1 Q
 ;
 I X?1."?" D  G OS1
 . W !!?5,"If the MUMPS system you are using is not listed, you cannot use"
 . W !?5,"this utility.  You must manually file DIDT, DIDTC, and DIRCR as"
 . W !?5,"%DT, %DTC, and %RCR, respectively."
 . W !!?5,"In addition, if you wish to use FileMan's screen-oriented utilities,"
 . W !?5,"you must file %ZIS and %ZISS routines (you can use DIIS and DIISS"
 . W !?5,"as starting points), and you must set the %ZOSF nodes manually."
 . W !?5,"Please refer the VA FileMan Programmer Manual for more information."
 ;
 S J=$P($T(@X),";;",2,999)
 I $T(@X)="" D  G OS1
 . W !!?5,$C(7)_"Invalid response.  Enter a number between 1 and 9."
 I $P(J,";",2)="*" D  G OS1
 . W !!?5,$C(7)_$P(J,";")_" is no longer supported."
 ;
 S DIOS=+X
 Q
 ;
1 ;;M/11;*
2 ;;M/SQL-PDP;*
3 ;;M/SQL
4 ;;DSM-4;*
5 ;;DSM for OpenVMS
6 ;;MSM
7 ;;DTM-PC
8 ;;GT.M(VAX)

DINZMSM
DINZMSM ;SFISC/AC-SETS ^%ZOSF FOR MSM-UNIX ;03:06 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
 F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z=""  S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=X
 S $P(^%ZOSF("OS"),"^")=$S($ZV["MSM":$P($ZV,","),1:"MSM")_"^8"
 K I,X,Z
 Q
 ;
Z ;;
 ;;ACTJ
 ;;S Y=$$ACTJ^%ZOSV()
 ;;AVJ
 ;;S Y=$$AVJ^%ZOSV()
 ;;BRK
 ;;B 1
 ;;CPU
 ;;Q
 ;;DEL
 ;;X "ZR  ZS @X" K ^UTILITY("%RD",X)
 ;;EOFF
 ;;U $I:(::::1)
 ;;EON
 ;;U $I:(:::::1)
 ;;EOT
 ;;S Y=$ZA\1024#2
 ;;ERRTN
 ;;^%ZTER
 ;;ETRP
 ;;Q
 ;;GD
 ;;D ^%GD
 ;;LABOFF
 ;;U IO:(::::1)
 ;;JOBPARAM
 ;;G JOBPAR^%ZOSV
 ;;LOAD
 ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
 ;;LPC;;Parity Check - ASCII sum
 ;;S Y=$ZCRC(X)
 ;;MAXSIZ
 ;;S %K=X D INT^%PARTSIZ
 ;;MAGTAPE
 ;;S %MT("BS")="*1",%MT("FS")="*2",%MT("WTM")="*3",%MT("WB")="*4",%MT("REW")="*5",%MT("RB")="*6",%MT("REL")="*7",%MT("WHL")="*8",%MT("WEL")="*9"
 ;;MTBOT
 ;;S Y=$ZA#2
 ;;MTERR
 ;;S Y=($ZA\256#8)+($ZA\4096#8)
 ;;MTONLINE
 ;;S Y=$ZA\16#4=3
 ;;MTWPROT
 ;;S Y=$ZA\2048#2
 ;;NBRK
 ;;B 0
 ;;NO-PASSALL
 ;;U $I:(:::::8388608)
 ;;NO-TYPE-AHEAD
 ;;U $I:(::::100663296)
 ;;PASSALL
 ;;U $I:(::::8388608)
 ;;PRIINQ
 ;;S Y=$$PRIINQ^%ZOSV()
 ;;PRIORITY
 ;;G PRIORITY^%ZOSV
 ;;PROGMODE
 ;;S Y=$$PROGMODE^%ZOSV()
 ;;RD
 ;;D ^%RD
 ;;RESJOB
 ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^KILLJOB[MGR]" D DO^%XUCI
 ;;RM
 ;;U:IOT["TRM" $I:X
 ;;RSEL
 ;;K ^UTILITY($J) G ^%RSEL
 ;;RSUM
 ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
 ;;SAVE
 ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X" S ^UTILITY("%RD",X)="" K XCS
 ;;SIZE
 ;;S Y=0 F I=1:1 S %=$T(+I) Q:%=""  S Y=Y+$L(%)+2
 ;;SS
 ;;D ^%SS
 ;;TEST
 ;;I $D(^ (X))
 ;;TMK
 ;;S Y=$ZA\128#2
 ;;TRAP
 ;;$ZT=X
 ;;TRMOFF
 ;;U $I:(::::::::$C(13,27))
 ;;TRMON
 ;;U $I:(::::::::$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))
 ;;TRMRD
 ;;S Y=$ZB
 ;;TYPE-AHEAD
 ;;U $I:(::::67108864:33554432)
 ;;UCI
 ;;S Y=$ZU(0)
 ;;UCICHECK
 ;;S Y=$$UCICHECK^%ZOSV(X)
 ;;UPPERCASE
 ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;;XY
 ;;U $I:(::::::DY*256+DX)
 ;;ZD
 ;;S Y=$ZD(X)

DINZVXD
DINZVXD ;SFISC/MVB-SETS %ZOSF FOR VAX DSM V6 ;03:21 PM  21 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
 F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z=""  S X=$P($T(Z+1+I),";;",2,99),^%ZOSF(Z)=X
 K I,X,Z
 Q
 ;
Z ;
 ;;OS
 ;;DSM for OpenVMS^16
 ;;ACTJ
 ;;S Y=$$ACTJ^%ZOSV()
 ;;AVJ
 ;;S Y=$$AVJ^%ZOSV()
 ;;BRK
 ;;U $I:CENABLE
 ;;DEL
 ;;X "ZR  ZS @X"
 ;;EOFF
 ;;U $I:NOECHO
 ;;EON
 ;;U $I:ECHO
 ;;EOT
 ;;S Y=$ZA\1024#2
 ;;ERRTN
 ;;^%ZTER
 ;;ETRP
 ;;Q
 ;;GD
 ;;G ^%GD
 ;;JOBPARAM
 ;;S Y=$$INFO^%SY(X),Y=$P(Y,",",1,2)
 ;;LABOFF
 ;;U IO:NOECHO
 ;;LOAD
 ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
 ;;LPC
 ;;S Y=$ZC(%LPC,X)
 ;;MAGTAPE
 ;;S %MT("BS")="*1",%MT("FS")="*2",%MT("WTM")="*3",%MT("WB")="*4",%MT("REW")="*5",%MT("RB")="*6",%MT("REL")="*7",%MT("WHL")="*8",%MT("WEL")="*9"
 ;;MAXSIZ
 ;;Q
 ;;MTBOT
 ;;S Y=$ZA\32#2
 ;;MTERR
 ;;S Y=$ZA\32768#2
 ;;MTONLINE
 ;;S Y=$ZA\64#2
 ;;MTWPROT
 ;;S Y=$ZA\4#2
 ;;NBRK
 ;;U $I:NOCENABLE
 ;;NO-PASSALL
 ;;G NOPASS^%ZOSV
 ;;NO-TYPE-AHEAD
 ;;U $I:NOTYPE
 ;;PASSALL
 ;;G PASSALL^%ZOSV
 ;;PRIINQ
 ;;S Y=$$PRIINQ^%ZOSV()
 ;;PRIORITY
 ;;G PRIORITY^%ZOSV
 ;;PROGMODE
 ;;S Y=$$PROGMODE^%ZOSV()
 ;;RD
 ;;G ^%RD
 ;;RESJOB
 ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^FORCEX[MGR]" D DO^%XUCI
 ;;RM
 ;;U $I:WIDTH=$S(X<256:X,1:0)
 ;;RSEL
 ;;K ^UTILITY($J) D ^%RSEL S X="" X "F %=0:1 S X=$O(%UTILITY(X)) Q:X=""""  S ^UTILITY($J,X)=""""" K %UTILITY
 ;;RSUM
 ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
 ;;SS
 ;;G ^%SY
 ;;SAVE
 ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS
 ;;SIZE
 ;;S Y=0 F I=1:1 S %=$T(+I) Q:%=""  S Y=Y+$L(%)+2
 ;;TEST
 ;;I $D(^ (X))!$D(^!(X))
 ;;TMK
 ;;S Y=$ZA\16384#2
 ;;TRAP
 ;;$ZT=X
 ;;TRMOFF
 ;;U $I:TERM=""
 ;;TRMON
 ;;U $I:TERM=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)
 ;;TRMRD
 ;;S Y=$ZB
 ;;TYPE-AHEAD
 ;;U $I:TYPE
 ;;UCI
 ;;S Y=$ZC(%UCI),Y=$P(Y,",",1)_","_$P(Y,",",4)
 ;;UCICHECK
 ;;S Y=$$UCICHECK^%ZOSV(X)
 ;;UPPERCASE
 ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;;XY
 ;;S $X=DX,$Y=DY
 ;;ZD
 ;;N % S Y=$ZC(%CDATASC,+X,1) F %=1:1:3 I $L($P(Y,"/",%))<2 S $P(Y,"/",%)=0_$P(Y,"/",%)

DIO
DIO ;SFISC/GFT,TKW-CALL SORT, ACTUAL OUTPUT ;11/23/94  10:43
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S Y=-1 K:$D(DCL)>9 ^DOSV(0,IO(0)) F Z=0:1 S Y=$O(DCL(Y)) Q:Y=""  S V=DCL(Y),^DOSV(0,IO(0),"F",+V)=Y_U_$P($G(^DD(+Y,+$P(Y,U,2),0)),U,1,2)
 I $G(DIOEND)["M^DIAU"!($G(DIOEND)["L^DIDC") S %X="DPP(",%Y="DIPP(" D %XY^%RCR S DIJS=DJ,DIPQ=DPQ,DIMS=M,DIPP=DPP
GO ;
 K DCL,DIASKHD,DIPT,DIPZ,DIL,DIL0,R,DOP,DHD,DD,DE,DG,DI,DIC,DK,DL,DN,DM,DU,DV,DW,DP,DY,POP,D,O,X,Y,V,DICS,TO,%X,%Y,DQ,%
 S DCC=U_$P(DJ,U,3),@("DD=$P("_DCC_"0),U,2)"),DP=+DD
 I '$D(DIBTPGM),+$G(DIBT1),$G(^DIBT(DIBT1,"ROU"))]"",DPQ S DIBTPGM=^("ROU") D
 . N DRN,DIERR D NXTNO^DIOZ(.DRN) I $G(DIERR) D QSV^DIOZ Q
 . S DIBTPGM=DIBTPGM_$E("000",1,(4-$L(DRN)))_DRN
 . Q 
 K:$G(DIBTPGM)="" DIBTPGM
 I '$D(DSC),'$G(DIO("SCR"))=1,DD["s",$D(^DD(DP,0,"SCR")) D SCR
 S DD=$P(DJ,U,4),DL="D0",DN=DL,DI=$S('$D(BY(0)):U,$E(BY(0))=U:U,1:"")_$P(DJ,U,2),A=1
 I $G(ZTSTOP)=1!($G(DIFMSTOP)) G IXK
 I $D(DIBTPGM) D
 .S (DICNT,DICP,DICDX,DICOV)=1 K DISAVX,DISETP,DISETQ,^TMP("DIBTC",$J)
 .I '$D(DSC),'$G(DIO("SCR")),$D(DIS)>9 D SVSCR
 .Q
 F Z=DD-1:-1:1 S @DL=-1,DL="D"_DL,DN=DL_C_DN
 S @DL=$S($D(DPP(DJK,"F"))&$D(DPP(DJK,"IX")):$P(DPP(DJK,"F"),U),DD>1:"",1:0),Z=0 D ^DIO0
 I DPQ G ^DIOS
IX I $D(DPP(DJK,"IX")),$O(^UTILITY($J,99,99))>99,DPP(DJK)-DP,'$D(DSC),DD>1 S X="I $D("_$P(DPP(DJK,"IX"),U,1,2)_DN F %=1:1 S X=X_",D"_% I %+1=DD S DSC(+DPP(DJK))=X_"))" Q
 I $D(CP) S C="",CP=0 F X=0:0 S C=$O(CP(C)),A="" Q:C=""  K CP(C) S CP(C,C)=0 F Y=0:0 S A=$O(CP(A)) Q:A=C  S CP(C,A)=0
 I $D(DIWL),DIWL=1 S ^(1)="S DIWF=""W"" "_^UTILITY($J,99,1)
IXK K DPP,DPQ,DJ,M,DISMIN,DISH
 I $G(ZTSTOP)=1!($G(DIFMSTOP)) I $G(DIBTPGM)]"" D
 .N % S %=+$P(DIBTPGM,"^DISZ",2) D:% ENRLS^DIOZ(%) K DIBTPGM Q
 D 2 S:'$D(Y) Y=1 G ^DIO4
 ;
2 ;
 I $D(DIBTPGM) D
 .I '$D(DPQ),$D(DX(0)) N %,X S %="D O^DIO2",(%(1),%(2))="DX",X=0 D SETU^DIOS
 .D ENC^DIOZ K ^UTILITY($J,0) Q
 K DLN,DL,F,I,J,V,W,X,Y,Z,DE,DRJ,DICP,DICDX,DICOV,DICNT,DISAVX,DISETP,DISETQ,^TMP("DIBTC",$J) D:'$D(DISYS) OS^DII
 I $G(ZTSTOP)=1!($G(DIFMSTOP))!($G(DIERR)) S (DJ,DIO)=0 Q
 S X=1 X ^DD("FUNC",18,1)
 I $D(DIOBEG) X DIOBEG K DIOBEG
 S I(0)=DCC,J(0)=DP,DI=99,(DN,X)=1,(DJ,DE,DIO,IOX,IOY)=0
 G ^DIO2
 ;
SCR S DD="S Y=D0 I $D("_DCC_"Y,0)) "_^("SCR") I '$D(DIS(0)) S:'$D(DIS) DIS=1 S DIS(0)=DD Q
 S DIS("SCR")=DD,DIS(0)=$S($D(DIBTPGM):"D DISCR",1:"X DIS(""SCR"")")_" I  "_DIS(0)
 Q
SVSCR ;SAVE DIS ARRAY INTO ^TMP FOR LATER COMPILATION
 N %,I,J,K S %=.0000001
 I $D(DIS)'=11 S ^TMP("DIBTC",$J,%,DICNT)="SEARCH S DIO=1",DICNT=DICNT+1
 S ^TMP("DIBTC",$J,%,DICNT)="SCR S DIO(""SCR"")=1",DICNT=DICNT+1
 S I="" I $D(DIS(0)) S ^(DICNT)=" "_DIS(0),I=" Q:'$T ",DICNT=DICNT+1
 S:$O(DIS(0)) I=I_" D S1 Q:'$T " I I]"" S ^(DICNT)=I,DICNT=DICNT+1
 S ^(DICNT)="PASS S:'$D(DPQ) DIPASS=1",^(DICNT+1)=" G O",DICNT=DICNT+2
 I $O(DIS(0)) S K=0 D
 .F J=1:1 Q:'$D(DIS(J))  S:K ^TMP("DIBTC",$J,%,DICNT)=" Q:$T",DICNT=DICNT+1 S ^(DICNT)=$P("S1 ^ ",U,K+1)_DIS(J),DICNT=DICNT+1,K=1
 .S ^(DICNT)=" Q",DICNT=DICNT+1 Q
 I $G(DIS("SCR"))]"" S ^TMP("DIBTC",$J,%,DICNT)="DISCR "_DIS("SCR"),^(DICNT+1)=" Q",DICNT=DICNT+2
 Q

DIO0
DIO0 ;SFISC/GFT,TKW-BUILD SORT AND SUB-HDR ;4/11/96  08:02
 ;;21.0;VA FileMan;**9,21**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S Z=Z+1,DE=$P(DN,C,Z)_"=$O("_DI_$P(DN,C,1,Z)_")),DN="_(Z+1)
 I Z=1,$G(DPP(DJK,"PTRIX"))]"" D
 . S DE="DD0=$O("_DPP(DJK,"PTRIX")_"DD0)),DN=1.5,DD00=0"
 . S DY(1.5)="S DD00=$O("_DPP(DJK,"PTRIX")_"DD0,DD00)),DN=2 S:'DD00 DN=1"
 . I DPP(DJK,"PTRIX")?.E1"""B""," S DY(1.5)=DY(1.5)_" S:DD00&($G(^(+DD00))!('($D(^(+DD00))=1))) DN=1"
 . Q
 I DPQ,Z=1,$D(DPP(DJK,"IX")),$O(DPP(DJK,0)) D
 .S DXIX=$P(DPP(DJK),U) Q:'DXIX  S DXIX(DXIX)=U_$P(DPP(DJK,"IX"),U,2)_$S($D(DPP(DJK,"PTRIX")):"DD00,D0",1:DN)
 .S W=0,%(1)="" F %=0:0 S W=$O(DPP(DJK,W)) Q:'W  S %=%+1,%(1)=%(1)_C_"D"_%
 .S DXIX(DXIX)=DXIX(DXIX)_%(1)
 .K %,W Q
 I Z<$G(DPP(0)) S Y=$P($G(DPP(Z+1,"F")),U) I Y]""!($G(DPP(Z+1,"T"))]"") S:+$P(Y,"E")'=Y Y=""""_Y_"""" S DE=DE_","_$P(DN,C,Z+1)_"="_Y
 I 'DPQ,$D(DPP(Z)) D H
 I DPQ,Z=DD S DE=DE_" S:D0 DISTP=DISTP+1 D:'(DISTP#100) CSTP"_$P("^DIO2",1,$D(DIBTPGM))_" Q:'DN "
 S X=DE_" I "_$P(DN,C,Z)_$S(DD=Z:"'>0",1:"=""""")
 S Y="" D
 .I Z=1,$D(DPP(DJK,"T")),$D(DPP(DJK,"IX")) S Y=$P(DPP(DJK,"T"),U)
 .I $G(DPP(0)),Z<(DPP(0)+1) S Y=$P($G(DPP(Z,"T")),U)
 .I Y]"",Y'="@",Y'="z" S X=X_"!("_$$AFT^DIOC($P(DN,C,Z),Y)_")"
 .Q
 S X=X_" S DN="_$S(Z=DD&($D(DPP(DJK,"PTRIX"))):1.5,1:(Z-1)),Y=Z-1 I Z=1,$D(DPP(DJK,"PTRIX")) S X=X_" K DD00",$P(DN,C,1)="DD00"
 I 'DPQ,$D(DPP(Y)) S:$P(DPP(Y),U,4)["!" X="DRK=DRK+1,"_X_",DRK=0",DRK=0 D SUB
 S DY(Z)="S "_X
 I $D(DIBTPGM) D
 . S DY(Z)=$S(Z'=1:"DY"_Z,1:"EN")_" Q:'DN  "_DY(Z)_$S(Z=1:" Q",Z=2&($D(DPP(DJK,"PTRIX"))):" G DYP",Z=2:" G EN",1:" G DY"_(Z-1))
 . I $D(DPP(DJK,"PTRIX")),Z=1 S DY(1.5)="DYP Q:'DN  "_DY(1.5)_" G:DN=1 EN"
 . Q
 G DIO0:Z<DD
 F %=1:1 Q:'$D(DPP(%))  K DPP(%,"PTRIX")
 S %=$S($G(DIO("SCR"))=1:"O",$D(DIS)<9:"O",$D(DIS)=11:"SCR",1:"SEARCH")
 S DY(Z+1)="S DN="_Z_" " I DJ["""B"",^" S DY(Z+1)=DY(Z+1)_"I $D("_DI_$P(DN,C,1,Z)_"))=1,'^(D0) "
 S DY(Z+1)=DY(Z+1)_"D "_%,Y=Z,X=""
 I 'DPQ,$D(DPP(Y)),$P(DPP(Y),U,2)=0 D SUB I  S DY(Z+1)=DY(Z+1)_" S "_$E(X,2,99)
 I A=1 D:$D(DIBTPGM) SETU Q
 S X=C F W=1:1:A-1 S ^DOSV(0,IO(0),"BY",W)=DPP(A(W)),X=X_$P(DN,C,A(W))_C,A(W)="Q"
 S A(W)="S ^DOSV(0,IO(0)"_C_W_X_"V,DE)=Y"
 D:$D(DIBTPGM) SETU Q
 ;
SUB I $P($G(DPP(Y)),U,4)["+" S A(A)=Y,X=X_",A="_A_" D"_$S($D(DIS)<9:"",1:":$D(DIPASS)")_" ^DIO3"_$S($D(DIS)<9:"",1:" K DIPASS"),A=A+1
 Q
 ;
H S DOP=0 I $D(DNP) F W=1:1 G Q:'$D(DPP(W)) I DPP(W)["+" K DNP S DOP=1 Q
 S Y=$P(DN,C,Z),F=$P(DPP(Z),U,5),W=$P(DPP(Z),U,4),X=$P(W,"""",2),V=+$P(DPP(Z),U,2) S:W["-" Y="(999999999-"_Y_")" I F'[""""&'$D(DPQ(+DPP(Z),V+X))&'DOP!(W["@")!(W["'")!$D(DISH) S (Y,V)="" G F:F]"",U
 I F[";TXT" S Y="$E("_Y_",2,$L("_Y_"))"
 S X=$S($D(^DD(+DPP(Z),V,0)):^(0),1:$P(DPP(Z),U,6,9)) I $P(X,U,2)["D" S Y=" S Y="_Y_" D DT"
 E  I $G(DPP(Z,"OUT"))]"" S DPP(Z,"OUT")=" S Y="_Y_" "_DPP(Z,"OUT"),Y=",Y"
 E  I $P(X,U,2)["O"!($P(X,U,4)?.P) S Y=C_Y
 E  D ^DILL
 S V=$P(F,";C",2),V="?"_$S(V:V-1,1:Z*3+5)
F I F[";S" S %=$P(F,";S",2) S:'% %=1 S V=$E("!!!!!!!!!!!!!!!!!!!!!!!!!!!!",1,%)_V,M=M+%
 S F=$P(F,";""",2),%=$S(W["@":"",W["'":"",F]"":$P(F,"""",1,$L(F,"""")-1),Y]"":$P($P(DPP(Z),U,3),"""",1)_": ",1:""),Y=V_$S(%_Y]"":$E(",",V]"")_""""_%_"""",1:"")_Y I Y]"" S Y=" D T"_$G(DPP(Z,"OUT"))_" W "_Y
U S W=W'["#" I W,Y="",$D(DPP(Z+1)) G E
 S ^UTILITY($J,"H",Z)="X ^UTILITY($J,1)"_$P(":$Y>"_(DIOSL-M-2-DD+Z)_"!(DC["","")",U,W)_Y,Y="D H:DI<DN ",DE=DE_$S(Z=1:",DI=0",1:" S:DI>"_Z_" DI="_Z)
 S:^UTILITY($J,99,0)'[Y ^(0)=Y_^(0)
E I DOP S DNP=""
Q K DOP Q
 ;
SETU ;PUT DY ARRAY INTO ^UTILITY FOR LATER COMPILATION
 N DN
 F DN=0:0 S DN=$O(DY(DN)) Q:'DN  D
 .S ^TMP("DIBTC",$J,0,DICNT)=$E(" ",'$O(DY(DN)))_DY(DN),DICNT=DICNT+1
 .I '$O(DY(DN)) S ^TMP("DIBTC",$J,0,DICNT)=$S(DN>2:" G DY"_(DN-1),1:" G EN"),DICNT=DICNT+1
 .Q
 Q

DIO1
DIO1 ;SFISC/GFT,TKW-BUILD P-ARRAY WHICH CREATES SORTED DATA ;9/1/94  12:41
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F DJ=0:1:7 F DX=-1:0 S DX=$O(Y(DJ,DX)) Q:DX=""  F DPR=-1:0 S DPR=$O(Y(DJ,DX,DPR)) D:DPR=""  Q:DPR=""  S X=0 D A
 .Q:'$D(DIBTPGM)  I $G(P(DX))]"" S %=P(DX),DISETQ=1 D SETU
 .Q
 K W S W="",Z=" S:$T ^UTILITY($J,0" F X=1:1:DPP D  I W]"" D OVZ
 .N % S %=$S($P(DPP(X),U,4)["'":1,1:J(X)) I ($L(Z)+$L(%))'>180 S Z=Z_C_% Q
 .I %=J(X),J(X)'="DISX("_X_")" S W=W_" S DISX("_X_")="_J(X),%="DISX("_X_")"
 .S Z=Z_C_% Q
 F V=1:1:DPP I V=DPP&(W="")!(DPP(V)-DP) S F=C,Y=DP,%=1,X=0 D U D:$L(W)+$L(Z)+$L(F)+$L(DX(DPQ))+$S(V(DPQ):38,1:0)>237  S W=W_Z_F_")="""""
 .I '$D(DIBTPGM) S DIOVFL(V)=$E(W,2,999),W=" X DIOVFL("_V_")" Q
 .S %=W,(%(1),%(2))="OV",W=" D OV"_DICOV D SETU^DIOS
 .Q
 F X=-1:0 S X=$O(DX(X)),DX=X Q:X=""  D
 .N A,B S A=""
 .I $D(DIBTPGM) S B=+$O(^TMP("DIBTC",$J,X,0)),A=$G(^(B))
 .S:$E(DX(X),1)=" " DX(X)=$E(DX(X),2,999)
 .S:A="" A=DX(X)
 .S:X=DPQ A=A_W_$P(",DJ=DJ+1",U,$D(DIS)>9)
 .I V(X) S F="",%(0)=DX,%=DCC S:$D(DXIX(DX)) F=DXIX(DX) D:F="" GREF^DIOU(.V,.%,.F) S A=A_" "_"S D"_V(X)_"=$O("_F_")) Q:D"_V(X)_"'>0"
 .S DX(X)=A Q:'$D(DIBTPGM)
 .S:B ^TMP("DIBTC",$J,X,B)=A S DX(X)="D "_$P(A," ")
 .Q
 S DX(0)=DX(DP),DX=0,DPQ=0 K:DP DX(DP)
 ;
2 K D,%,I D 2^DIO I $G(DIERR) G IXK^DIO
 K DIOVFL,P,V,Y,D0,D1,D2,D3 K:'$D(DIB) DIS S:$D(DIBTPGM) DIBTPGM=""
 S V="I $D(^UTILITY($J,0" K DPP(0,"F"),DPP(0,"T") F X=1:1:DPP K DPP(X,"F"),DPP(X,"T") S V=V_$E(",DDDDDDDDDDD",1,DPP+3-X)_0
 F X=-1:0 S X=$O(DX(X)) Q:X=""  I $D(DX(X,U)) S DSC(X)=V_DX(X,U)_$S($D(DSC(X)):" "_DSC(X),1:"")
 K DX S DX=^UTILITY($J,"DX"),DJ=^("F"),%=$O(^("DX",-1)) S:%="" %=-1 F %=%:0 S DX(%)=^(%),%=$O(^(%)) I %="" G GO^DIO
 ;
U S:$D(D(Y)) X=X_D(Y) S %=%+1,Y=$P(Z(V),C,%),D=Y="",F=$S(F'=C:F_",D"_X,D:",D"_X,1:",D"_X_C_V) Q:D  S X=V(Y) G U
 ;
A S X=$O(Y(DJ,DX,DPR,X)) Q:X=""  D B G A
 ;
B S DL=Y(DJ,DX,DPR,X),W="DISX("_DL_")",DIO="=""""",D2=""
 I 'X,DL>$G(DPP(0)) S:'$D(DPP(DL,"CM")) W="D"_V(DX),DIO="<0"
 I X S Z=$P($P(^DD(DX,+X,0),U,4),";",2) S:$E(Z)="E" DIO="?."" """
 S Z="" S:$C(63,122)=$P($G(DPP(DL,"F")),U) Z=1 S:$P($G(DPP(DL,"T")),U)="@" Z=Z+2
 S F=$S($P(DPP(DL),U,4)["-":"999999999-",$P(DPP(DL),U,10)=2:"+",1:"")_$S($D(DE(DL)):"$E("_W_",1,"_DE(DL)_")",1:W)
 I Z S F="$S("_W_"'"_DIO_":"_F_",1:""  EMPTY"")" I Z>2 S F=""" """
 S J(DL)=F
 S P(DX)=$S($D(P(DX)):P(DX)_" ",1:"")
 S Y=$S($E(W,1,5)="DISX(":"S "_W_"="""" ",1:"")_DPP(DL,"GET")
 S DLN=$G(DPP(DL,"QCON")) I DL=DJK&$D(DPP(DL,"IX"))!(DLN="") S DLN="I "_W_"]"""""
 I $D(DIBTPGM) D  G BX
 .N % I $L(P(DX))+$L(Y)+$L(DLN)>237 S %=$E(P(DX),1,($L(P(DX))-1)) D SETU S P(DX)="I  "
 .S P(DX)=P(DX)_Y_" "_DLN Q
 I DPP>2!($L(P(DX))+$L(Y)>125) F Z=1:1 I '$D(P(DX,Z)) S P(DX,Z)=Y,P(DX)=P(DX)_"X P("_DX_C_Z_")"_$P(" I ",C,Y[" I ")_" "_DLN Q
 E  S P(DX)=P(DX)_Y_" "_DLN
BX S Y=DX Q
 ;
OVZ I '$D(DIBTPGM) S DIOVFL("SX"_X)=$E(W,2,999),Z=" X DIOVFL(""SX"_X_""") "_Z,W="" Q
 N % I $D(DIBTPGM) S %=W,(%(1),%(2))="OV",Z=" D OV"_DICOV_" "_Z D SETU^DIOS
 S W="" Q
 ;
SETU Q:%=""  N A
 S A=$G(DICP(DX)) I A S A="P"_A
 S ^TMP("DIBTC",$J,"P",DICNT)=A_" "_%
 I $D(DISETQ) S ^((DICNT+.001))=" Q" K DISETQ
 K DICP(DX) S DICNT=DICNT+1
 Q

DIO2
DIO2 ;SFISC/GFT,TKW-PRINT ;9/20/94  14:11
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S (DISTP,DILCT)=0
XDY I $D(DIBTPGM) D @("EN"_DIBTPGM),ENRLS^DIOZ(+$P(DIBTPGM,"^DISZ",2)) Q
 X DY(DN) G XDY:DN
 Q
 ;
SEARCH S DIO=1
SCR S DIO("SCR")=1,DE=0 I '$D(DIS(0)) G OR
 X DIS(0) Q:'$T  G PASS:'$D(DIS(1))
OR S DE=DE+1 I '$D(DIS(DE)) Q
 X DIS(DE) E  G OR
PASS S:'$D(DPQ) DIPASS=1
O F DLP=0:1:DX Q:'DN  X $S($D(DPQ):DX(DLP),1:^UTILITY($J,99,DLP))
 Q
 ;
N W !
T I $X,IOT'="MT" W !
 I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
 S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP
 Q
 ;
CSTP I $G(IOT)="SPL"!($G(IOT)="HFS") I '$D(DPQ),$$ROUEXIST^DILIBF("XUPARAM"),DILCT>$$KSP^XUPARAM("SPOOL LINES") D  Q
 . S DIFMSTOP=1,DN=0 S:$D(ZTQUEUED) ZTSTOP=1
 . W !,"*** JOB STOPPED BECAUSE MAXIMUM SPOOL LINES HAS BEEN EXCEEDED ***",!! Q
 I '$D(ZTQUEUED) K DISTOP Q
 Q:$G(DISTOP)=0  S:$G(DISTOP)="" DISTOP=1
 I DISTOP'=1 X DISTOP K:'$T DISTOP S DISTOP=$T Q:'$T
 Q:'$$S^%ZTLOAD
 W:$G(IO)]"" !,"*** TASK "_ZTSK_" STOPPED BY USER - DURING "_$S($D(DPQ):"SORT",1:"PRINT")_" EXECUTION ***",!! S ZTSTOP=1,DN=0 Q
 ;
DT I $G(DDXPDATE) D DT^DDXP4 W DDXPY K DDXPY Q
 I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
 I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
 W Y Q
 ;
C S DQ(C)=Y
S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
P S N(C)=N(C)+1
A S S(C)=S(C)+Y Q
D I Y=DITTO(C) S Y="" Q
 S DITTO(C)=Y Q
 ;
CP S C="" F  S C=$O(CP(C)) Q:C=""  G DQ:'$D(DQ(C))
 S CP=CP+1 F  S C=$O(CP(C)),A="" Q:C=""  F  S A=$O(CP(A)) S CP(C,A)=DQ(C)*DQ(A)+CP(C,A) Q:A=C
DQ K DQ Q
 ;
H F DI=DI:1:DN I $D(^UTILITY($J,"H",DI)) X ^UTILITY($J,"H",DI) W:$X&($G(DIAR)'=4)&($G(DIAR)'=6) !
 Q
 ;
M X $S($D(DPQ):DX(DIXX),1:^UTILITY($J,99,DIXX))

DIO3
DIO3 ;SFISC/GFT-TTLS, SUBTTLS ;12/22/92  10:58 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SUB ;
 W:'$D(DNP)&$X ! K X I $D(^UTILITY($J,"SV",A+1)) F Y="S","N","Q","H","L" S C=Y_"(V)" F V=0:0 S V=$O(@C) Q:V=""  I $D(^UTILITY($J,"SV",A+1,V,Y)) S @C=^(Y),^(Y)=$S(Y="H":-99999999,Y="L":99999999,1:0)
 K V F %X=-1:0 S %X=$O(^UTILITY($J,"T",%X)) Q:%X=""  S Z=^(%X),V=$P(Z,U,2),V(V)="" D U
 S Z=A I $D(A(A)) F DE="S","N" S I=DE_"(V)" F V=0:0 S V=$O(@I) Q:V=""  S Y=@I I '$D(DNP)!Y S:'$D(V(V)) ^(DE)=$G(^UTILITY($J,"SV",A,V,DE))+Y S @I=0,Z=0 X A(A)
 S X=-1 G K:$D(X)<9!Z F I=0:0 S I=$O(X(I)),X=X+1 Q:I=""
 I X+$Y>IOSL X ^UTILITY($J,1)
 F I=0:0 S I=$O(X(I)),X=-1 Q:I=""  W:$X ! W $P("SUB",U,A>0),$P($T(@I),";",3)," " F %=0:0 S X=$O(X(I,X)) Q:X=""  W ?X,X(I,X)
 W !
K K Z,X,V,C Q
 ;
U F I=1:1:6 S DE=$P($T(@I),";",4),Y=DE_"(V)" I $D(@Y)#2 S Y=@Y,C=$P(Z,U,5) D @I
 I '$D(DNP),$D(X)>9 W ?%X F I=1:1:Z W "-"
 Q
1 ;;TOTAL;S
 I $P(Z,U,6)]"" X $P(Z,U,6,99) S S(V)=Y
 S ^(DE)=$S($S(A:$D(^UTILITY($J,"SV",A,V,DE)),1:$D(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
 Q:Z["D"  Q:Z["F"&(Y=0)
O I C]""!$P(Z,U,3) S @("Y=$J(Y,+Z"_C_")")
 S X(I,%X)=Y Q
2 ;;COUNT;N
 S ^(DE)=$S($S(A:$D(^UTILITY($J,"SV",A,V,DE)),1:$D(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
 S C=$P(",0",U,C]"") G O
3 ;;MEAN;N
 Q:Z["D"!'Y!$L($P(Z,U,6))!'$D(S(V))  Q:Z["F"!A&(S(V)=0)  S Y=$J(S(V)/Y,0,2) G O
4 ;;MINIMUM;L
 S ^(DE)=$S('$D(^(DE)):Y,^(DE)>Y:Y,1:^(DE)),L(V)=99999999 G M
5 ;;MAXIMUM;H
 S ^(DE)=$S('$D(^(DE)):Y,^(DE)<Y:Y,1:^(DE)),H(V)=-99999999
M Q:Y[9999999!(N(V)<2)  D D:Z["D" G O
6 ;;DEV.;Q
 Q:Z["D"  S ^(DE)=$G(^(DE))+Y,Q(V)=0 Q:N(V)<2  S DE=Y-((S(V)*S(V))/N(V))/(N(V)-1),Y=1+DE/2 Q:DE'>0
L S %=Y,Y=DE/%+%/2 G L:Y<%,O
 ;
DT D D:Y W Y Q
D S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:"  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
 Q
N W !
T Q

DIO4
DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;12/1/94  11:10
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DIXX,DIWT,DIW,DIP,DSC,DRK,DIO("SCR") D:'$D(DISYS) OS^DII
 G:$G(DIFIXPT)=1 K1
 I $G(DIBTPGM)]"" D
 .N % S %=+$P(DIBTPGM,"^DISZ",2) D:% ENRLS^DIOZ(%) K DIBTPGM Q
 I ($G(ZTSTOP)=1!($G(DIFMSTOP))!($G(DIERR)))&'$D(DIAR) K:$G(ZTQUEUED) DIERR,^TMP("DIERR",$J) D FF G STOP
 I $D(^UTILITY($J,"T")) S A=0 D ^DIO3
 I L!($D(DISTEMP)),DIO,'DISUPNO D:'DJ&('DC)&($D(^UTILITY($J,2))) HDR W !!!?25,DJ," MATCH",$P("ES",U,DJ'=1)," FOUND." W:IOST?1"C".E $C(7)
 I DIO,$G(DISV),$D(^DIBT(DISV)) D NOW^%DTC S ^DIBT(DISV,"QR")=%_U_+DJ
 I $G(DISTP)<1,'DIO,'DISUPNO,'DC D:$D(^UTILITY($J,2)) HDR W !!!!,?10,"*** NO RECORDS TO PRINT ***"
 I $D(DIAR) D UPDATE^DIARU
 I $D(CP) S X=-1,^DOSV(0,IO(0),"CP")=CP F  S X=$O(CP(X)),Z=-1 Q:X=""  F  S Z=$O(CP(X,Z)) Q:Z=""  S ^DOSV(0,IO(0),"CP",X,Z)=CP(X,Z) Q:X=Z
 I $D(DIOT),$D(Y),Y'=U S DY(1)="X DIOT S DN=0",DN=1 D ^DIO2
 D FF
 I $D(DCOPIES),$D(DOUT),$D(^DD("OS",DISYS,"SDPEND")) D SDP
 G:$G(DIOEND)="G M^DIAU" M^DIAU G:$G(DIOEND)="G L^DIDC" L^DIDC
 X:$D(DIOEND) DIOEND K DIOEND
STOP I $G(ZTSTOP)=1,$G(DISTOP("C"))]"" X DISTOP("C")
 D CLOSE I DUZ(0)'="@" S X=0 X ^DD("FUNC",18,1)
K ;S:$D(ZTSK) ZTREQ="@"
 I $D(ZTQUEUED) D
 . S ZTREQ="@"
 . I $G(DDXPTMDL),$D(DDXPXTNO) N DA,DIK S DIK="^DIPT(",DA=DDXPXTNO D ^DIK
K1 K ^UTILITY($J),^(U,$J),^UTILITY("DIP2",$J),FLDS,DIOT,DQI,A,B,C,D,E,H,I,J,M,N,L,P,Q,S,V,W,X,Y,Z,DITTO,DIP,DIPA,BY
 K %,%H,%I,%A,%B,%DT,%Q,%X,%Y,%Z,FR,CP,DA,DD,DIO,DL,DM,DN,DI,DE,D9,D5,D4,D3,D2,D1,DCOPIES,DIFF,DIASKHD,DISTOP,DISTP,DILCT,DISV,DISX,DIAC,DIFILE
 K DIS,SF,D0,DD0,DDD0,DDDD0,DDDDD0,DDDDDD0,DIPDT,DIPR,DICMX,DHT,DIWL,DIWR,DIPASS,DICSS
 K DIRUT,DIROUT,DUOUT,DTOUT,DIHELP,DIMSG,^TMP("DIHELP",$J),^TMP("DIMSG",$J)
 I '$G(DIQUIET) K ^TMP("DIERR",$J),DIERR
 K DIBT,DIBT1,DIBT2,DX,DY,DNP,DC,DXS,DINS,DIPT,IOP,DCC,DQ,DJ,DJK,DIOP,DIOSL,DLP,DILIOSL,DHIT,DIJ,DPR,DP,DISUPNO,DIPCRIT,DIBTOLD,DITYP,DISTXT Q
 ;
FF W:IOST?1"P".E&$Y&L @IOF
 Q
 ;
SDP Q:'DCOPIES  W ! X ^DD("OS",DISYS,"SDPEND")
 S DIO=IO,DLP=IOPAR,IOP=DOUT,A=IO(0) D ^%ZIS S IO(0)=A Q:POP
 F A=1:1:DCOPIES W:IOST?1"P".E&$Y @IOF X ^DD("OS",DISYS,"SDP") U IO
 I IO'=IO(0) S X=IO X ^DD("FUNC",7,1) K IO(1,IO)
 S IO=DIO Q
 ;
CLOSE ;
 S DIOP=IO X $G(^%ZIS("C"))
 I $P(IO(0),DIOP)]"" S IOP=IO(0) D ^%ZIS H:POP  S X=DIOP X ^DD("FUNC",7,1) K IO(1,IO) U IO(0)
 K DIOP Q
HDR N DN S DN=1 X ^UTILITY($J,1) Q
N G N^DIO2
T G T^DIO2
CSTP G CSTP^DIO2
DT G DT^DIO2 Q
C G C^DIO2
S G S^DIO2
P G P^DIO2
A G A^DIO2
D G D^DIO2
CP G CP^DIO2
H G H^DIO2
M G M^DIO2

DIOC
DIOC ;SFISC/TKW-GENERATE CODE TO CHECK QUERY CONDITIONS ;8/25/93  16:01
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BEF(X,Y,N,M) ; BEFORE  (X before Y)
 N Z S:+$P(Y,"E")'=Y Y=""""_Y_""""
 I $G(N)="'" S Z=Y_"']]"_X Q Z
 S Z="" S:$G(M)]"" Z=X_"]"""","
 S Z=Z_Y_"]]"_X Q Z
AFT(X,Y,N,M) ; AFTER (X after Y)
 N Z S:+$P(Y,"E")'=Y Y=""""_Y_""""
 I $G(N)="'" S Z="" S:$G(M)]"" Z=X_"]""""," S Z=Z_X_"']]"_Y Q Z
 S Z=X_"]]"_Y Q Z
BTWI(X,F,T,N,S) ;BETWEEN INCLUSIVE  (NOTE: Param.'S' defined only if called from sort.
 S S=$G(S) N Z
 I $G(N)="'" S Z="("_$$BEF(X,F)_")!("_$$AFT(X,T)_")" Q Z
 S:S]"" Z=$$AFT(X,F)
 I S="" S:+$P(F,"E")'=F F=""""_F_"""" S Z=F_"']]"_X
 S Z="("_Z_")&("_$$AFT(X,T,"'")_")" Q Z
BTWE(X,F,T,N) ;BETWEEN EXCLUSIVE
 N Z S:+$P(T,"E")'=T T=""""_T_""""
 I $G(N)="'" S Z="("_$$AFT(X,F,"'")_")!("_T_"']]"_X_")" Q Z
 S Z="("_$$AFT(X,F)_")&("_T_"]]"_X_")" Q Z
EQ(X,Y,N) ;EQUALS
 N Z S:$G(N)'="'" N="" S:+$P(Y,"E")'=Y Y=""""_Y_"""" S Z=X_N_"="_Y Q Z
NULL(X,N) ;NULL
 N Z S:$G(N)'="'" N="" S Z=X_N_"=""""" Q Z

DIOQ
DIOQ ;SFISC/GS,TKW-QUERY OPTIMIZER ;4/5/95  14:02
 ;;21.0;VA FileMan;**2**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
SER(F,DIOQGET,DIOQCHEK,C,X,%,W) ; COMPUTE SEARCH EFFICIENCY RATING
 ; F=FILE#, DIOQGET=GET CODE, DIOQCHEK=EVALUATION CODE,
 ; C=USEABLE INDEX? (1=YES, 0=NO)
 ; X=EFFICIENCY RATING, %=PREVALANCE OF HITS (PROBABILITY)
 ; W=WRITE PROGRESS MSG.TO USER
 N Z S (X,%)=0,W=$G(W),Z=$G(^DIC(+$G(F),0,"GL")) Q:Z=""
 N I,N,T,D0,DA,DITRUE,DIFIRST S DIFIRST=1
 I W S W=$P($H,",",2)+.1
 S (T,N)=0,I=$P(@(Z_"0)"),U,4)\100
 F D0=0:I S D0=$O(@(Z_D0_")")) Q:'D0  Q:N>100  S DA=D0,N=N+1 D TEST I DITRUE S T=T+1
 S %=$S(N=0:1,T=0:0,1:T/N),(X,%)=1-% I C S:%=1 X=100 S:%'=1 X=%/(1-%)
 S X=$J(X,1,4),%=$J(%,1,4) Q
 ;
TEST ; GET VALUE AND EVALUATE IT
 N I,L,N,T,Z,DIOQSVD0 S DIOQSVD0=D0 D  S D0=DIOQSVD0
 . N F,C,W,DIFIRST
 . X DIOQGET,DIOQCHEK S DITRUE=$T Q
 Q:'W  Q:($P($H,",",2)-W)'>3  S W=$P($H,",",2)+.1
 I DIFIRST S DIFIRST=0 W !,"Computing search efficiency..." Q
 W "." Q

DIOS
DIOS ;SFISC/GFT,TKW-BUILD SORT LOGIC ;9/2/94  11:19
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D INIT S ^UTILITY($J,"DX")=DX,^("F")="^UTILITY($J,0,"_DCC_U_(DPP+1)
 F X=-1:0 S X=$O(DX(X)) Q:X=""  S ^UTILITY($J,"DX",X)=DX(X)
C K DX F DL=1:1:DPP S DX=+DPP(DL),V(DX,2)=DL,X=DP,(DPQ,DJ)=0,Z(DL)="" D A S X=999-$P($G(DPP(DL,"SER")),U,2),Y(DPQ,DX,X,$E($P(DPP(DL),U,2,3),1,30))=DL
 F DL=1:1:DPP K %,DIOS S Z=Z(DL),%=0 D U I D5,DE>0,$D(DE(DL))=1 S DE(DL)=DE(DL)-(DE\D5) S:DE(DL)<4 DE(DL)=4
 S I=DP G GO
 ;
U S D="",%=%+1,Y=$P(Z,C,%) Q:Y=""
 S %(%)="D"_V(Y) I $D(V(Y,9)) F I=1:1:%-1 S %(I)="I("_V($P(Z,C,I))_",0)"
 F I=1:1:% S D=D_C_%(I) I I=1 S D=D_C_DL
 S DX(Y,U)=D_"))" G U
 ;
A S W=$D(DPP(DL,X)),V(X)=DJ,Z(DL)=Z(DL)_X_C G ^DIOS1:'W
 I W=1 S Z=X,V=DPP(DL,X),DJ=DJ+1,DPQ=DPQ+1,X=$O(DPP(DL,X)) S:X="" X=-1 S:+V'=V V=Q_V_Q S:$S($D(^DD(X,0,"UP")):^("UP")-Z,1:1) X=DX K J(DJ,X) S:J'<DJ&$D(J(DJ)) J=DJ-1 S J(DJ,X)=DL,V(X,1)=V,V(X,0)=Z,I(Z,X)=DL G A
 S W=-1
O S W=$O(DPP(DL,X,W)) I W="" S X=+V G A
 S V=DPP(DL,X,W),DJ=W#100,V(+V,9,DL)=W,V(+V,8)=U_$P(V,U,2),DPQ=DPQ+1+DJ,I(X,+V)=DL,J=-1,J(DJ,X)=DL G O
 ;
GO K DISETP,DISAVX S X=I,I="" I $D(V(X,2)) S I=" X P("_X_")" I $D(DIBTPGM) S I=" D P"_DICP,DISETP=1
 I V(X) S W="D"_V(X),I="F "_W_"="_W_":0"_I
 S DX(X)=I,DPQ=X
 S DX=X,I=$O(I(X,X)),F=-1 I I="" D  I I="" G DIO1
 . I $D(I)<9 Q:'$D(DIBTPGM)  Q:$D(DISAVX(X))  S %=DX(X),%(1)=X,%(2)="DX" D SETU Q
 . S I=$O(I(X,-1)) Q:I]""
 . S I=$O(I(DP,-1)) I I]"" S DX=DP Q
 . S DX=+$O(I(-1)),I=+$O(I(DX,-1))
 . Q
 S P=I(DX,I) K I(DX,I) G COLON:$D(V(I,9)) D MULPATH
 S F="",(DX,%(0))=I,W="D"_V(I),%=DCC S:$D(DXIX(I)) F=DXIX(I) D:F="" GREF^DIOU(.V,.%,.F)
 S DX(X)=DX(X)_" S "_D2_W_"=$O("_$E(F,1,$L(F)-2)_"0))"_DN_$P(")",U,'$D(DIBTPGM))_D1
 I $D(DIBTPGM) S %=DX(X),%(1)=X,%(2)="DX" D SETU
 G GO
COLON S F=$O(V(I,9,F)) I F="" G GO
 D MULPATH S DX(X)=DX(X)_$E(" S "_D2,1,$S(D2]"":$L(D2)+2,1:0))_DN I '$D(DIBTPGM) S DX(X)=DX(X)_C_F_")"
 S DX(X)=DX(X)_D1
 I $D(DIBTPGM) S %=DX(X),%(1)=X,%(2)="DX" D SETU
 S DN=DPP(F,DX,V(I,9,F)),V=$P(DN,U,4,99)
 I $P(DN,U,3) S V="S DIXX="_I_" "_V
 E  S V=V_" S D0=D(0) " D
 .I '$D(DIBTPGM) S V=V_"X DX("_I_")" Q
 .S V=V_"D DX"_DICDX
 .Q
 S DX(I,F)=V I $D(DIBTPGM) S %=V,%(1)=I_","_F,%(2)="DX" D SETU
 G COLON
 ;
MULPATH S DN=" "_$E("XD",$D(DIBTPGM)+1)_$P(":$T",1,$D(V(X,2)))_" DX" D
 .I $D(DIBTPGM) S DN=DN_DICDX Q
 .S DN=DN_"("_I Q
 S (D1,D2)="" F Z=J+1:1:V(X) S W="D"_Z,D(X)="("_X_C_P_")",%=W_D(X),D2=%_"="_W_C_D2,D1=$S(D1]"":D1_C,1:" S ")_W_"="_%
 F V=0:1 S Y=$S($D(J(V,X)):X,$O(J(V,-1)):$O(J(V,-1)),1:-1) D:$D(D(Y))  Q:V'<V(X)
 . I V<V(X) S DN=" S D"_V_"=D"_V_D(Y)_DN
 . Q:'$D(V(X,9))
 . S:V=0 DN=" N I,DIXX"_DN
 . Q:V<V(X)
 . I $D(V(X,2)) S DN=" S D"_V_"=D"_V_D(Y)_DN
 . Q
 Q
 ;
SETU ;FILE A LINE TO ^TMP FOR LATER INCLUSION IN ROUTINE
 Q:%=""  N A
 I %(2)="DX" S A=$S(DICDX=1:"O",1:"DX"_(DICDX-1)),DISAVX(X)=""
 I %(2)'="DX" S A=%(2)_DICOV,DICOV=DICOV+1
 S %=A_$E(" ",$E(%)'=" ")_%
 S ^TMP("DIBTC",$J,%(1),DICNT)=%,^((DICNT+.001))=" Q"
 S A="DIC"_%(2) S @(A)=@(A)+1,DICNT=DICNT+1
 I %(2)="DX",$D(DISETP) S DICP(X)=DICP,DICP=DICP+1 K DISETP
 Q
 ;
INIT S:'$D(L) L=1 I $G(IO)=IO(0),L'=0,($G(IOST)=""!($G(IOST)?1"C".E)) D WAIT^DICD
 K I,J,Z S J=99,Q="""",DE=DPP*8-$S($D(^DD("SUB")):^("SUB"),1:127)+23,D5=0,DIOS=$P(^DD("OS",DISYS,0),U,7) S:'DIOS DIOS=63
 Q
 ;
DIO1 K %,I,J,P G ^DIO1

DIOS1
DIOS1 ;SFISC/GFT-BUILD SORT LOGIC ;10/12/94  11:08
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
L S X=$P(DPP(DL),U,2) S:X=0 X=.001
 S W=+$P($P(DPP(DL),U,5),";L",2) I W D  G SL
 . I $P(DPP(DL),U,5)[";TXT" S W=W+1
 . S W=$S(W<DIOS:W,1:DIOS),DE(DL)=W,DE(DL,"SIC")=1 Q
 I '$D(^DD(DX,+X,0)) S W=+$P($P(DPP(DL),U,4),"""",2) I '$D(^DD(DX,W,0)) S W=30 G DJ:$P(DPP(DL),U,7)["D",LL
X S DN=$P(^(0),U,2),W=+$P(DN,"J",2) G LL:W>8,DJ:W I $P(DN,"P",2) G X:$D(^DD(+$P(DN,"P",2),.01,0)),LL
 I DN["C",DN'["J" S W=30 G LL
 I DN'["F" S DE=DE+5,W=13 S:$P(DPP(DL),U,5)[";TXT" W=14 G DJ
 S W=+$P(^(0),"$L(X)>",2) S:'W W=30 S:W>DIOS W=DIOS
LL I $P(DPP(DL),U,5)[";TXT" S W=W+1
 S:W>8 DE(DL)=W,D5=D5+1
SL S DE=DE+W-8
DJ I $O(DPP(DL,-1)) D  I X=.001 S DE=DE+W
 . N I,J S I=0
 . F J=0:0 S J=$O(DPP(DL,J)) Q:'J  S I=I+1
 . S DE=(I*4)+DE Q
 Q

DIOU
DIOU ;SFISC/TKW-GENERIC FILEMAN CODE GENERATION UTILITIES ;8/23/95  13:42
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BIJ(S,F,I,J) ;BUILD I & J ARRAY.  S=(SUB)FILE#, F=FIELD#
 N X,Y,% S X=0,(Y,J(0))=S F  Q:'$D(^DD(Y,0,"UP"))  S X=X+1,Y=^("UP")
 I X=0 G X
 F %=X:-1:1 S Y=$G(^DD(S,0,"UP")) Q:'Y  S I(S)=%,I(S,0)=Y,F=$O(^DD(Y,"SB",S,0)) Q:'F  S I(S,1)=$P($P($G(^DD(Y,F,0)),U,4),";"),S=Y
X S J=$G(^DIC(S,0,"GL")),I(S)=0
 I $G(DCC)?1"^"1.A1"(".E,((J="")!($P(DCC,J,2)]"")) S J=DCC
 Q
GREF(I,J,F) ;BUILD GLOBAL REFERENCE (I & J ARRAY FROM BIJ, CODE RETURNED IN F)
 N %,Y S F="",%=J(0) F Y=I(%):-1 S F="D"_Y_F Q:'Y  S F=","_$G(I(%,1))_","_F,%=$G(I(%,0)) Q:%=""!('$D(^DD(+%)))
 S F=$S($D(I(%,8)):I(%,8),1:J)_F Q
GLRF(S,F,X,%) ;BUILD GLOBAL REFERENCE (S=(SUB)FILE#,F=FIELD NO.,%=CLOSE PARENTHESIS, RETURN PIECE IN %, X=OUTPUT VARIABLE.)
 Q:'$D(^DD($G(S),$G(F),0))  N I,J,K,L,Y D BIJ(S,F,.I,.J)
 S X="",K=J(0) F Y=I(K):-1 S X="D"_Y_X Q:'Y  S L=$G(I(K,1)) S:L]""&(+$P(L,"E")'=L) L=$$QUOTE^DILIBF(L) S:L]"" X=","_L_","_X S K=+$G(I(K,0)) Q:'K
 S X=J_X_"," Q:$G(%)=""
 S %=$P($P(^DD(S,F,0),U,4),";",1) I %]"",+$P(%,"E")'=% S %=$$QUOTE^DILIBF(%)
 S X=X_%_")",%=$P($P(^DD(S,F,0),U,4),";",2) S:F=.001 %(1)=I(J(0)) Q
GET(S,F,X,Y,DIFLAG) ;BUILD CODE TO EXTRACT FIELD.  S=FILE/SUBFILE#, F=FIELD#, X=LOCAL VARIABLE NAME WHERE FIELD WILL BE STORED.  CODE RETURNED IN Y
 ; DIFLAG["I" if internal value of field (no output transform)
 N % Q:'$D(^DD(+$G(S),+$G(F),0))  S %=^(0),%(2)=$G(^(2))
 N P,DN,I,J
 S P=1 D GLRF(S,F,.Y,.P)
 I F=.001,P="" S Y="S "_X_"=D"_P(1) Q
 I P=" " G CAL
 I P S DN="$P(",P="),U,"_P_")"
 I $E(P)="E" S DN="$E(",P="),"_$E(P,2,9)_")"
 I $G(DN)="" Q
 S Y="S "_X_"="_DN_"$G("_Y_P
 Q:$G(DIFLAG)["I"
 I %(2)]"",$P(%,U,2)["O",$P(%,U,2)'["D" S Y=Y_",Y="_X_" "_%(2)_" S "_X_"=Y"
 Q
CAL S Y=$P(%,U,5,99)_" S "_X_"=X" Q
 ;
DTYP(S,F,Y) ;RETURN DATA TYPES(S) FOR A FIELD
 K Y S Y=""
 I $G(F)=.001,$G(^DD(+$G(S),F,0))="" S Y=2 Q
D2 Q:$G(^DD(+$G(S),+$G(F),0))=""  N %,%X,%Y,X,I,J,DITYP
 S %=$P(^(0),U,2),%(1)=$P(^(0),U,3),%(4)=$P(^(0),U,5,99),DITYP=""
 I '% S I="" F  S I=$O(^DI(.81,"C",I)) Q:I=""  I %[I S DITYP=$O(^(I,0)) Q
 I DITYP="",% D  G:'DITYP D2
 . I $P($G(^DD(+%,.01,0)),U,2)["W" S DITYP=5 Q
 . S S=+%,F=.01 K % Q
 S:Y="" Y=DITYP
 I DITYP=1 S Y("D")="",%(4)=$P($P(%(4),"%DT=",2),"""",2) S:%(4)["T"!(%(4)["R")!(%(4)="") Y("D")=Y("D")_"T" S:%(4)["S" Y("D")=Y("D")_"S" G QD
 I DITYP,"2,4,5,9"[DITYP G QD
 Q:Y=""
 I DITYP=6 S Y("T")=$S(%["D":1,%["B":2,%?.E1"J".N1","1N.E:2,1:4) Q
P I DITYP=7 S I=+$P(%,"P",2),%(2)="Y(" D Y S S=I,F=.01 K % G D2
V I DITYP=8 S X=0 D V2 Q
S I DITYP=3 F I=1:1 S X=$P(%(1),";",I),X(1)=$P(X,":"),X=$P(X,":",2) Q:X=""!(X(1)="")  S Y("S","I",X(1))=X,Y("S","E",X)=X(1)
QD I $O(Y(-1)) S Y("T")=DITYP
 Q
Y S %(3)=$O(@(%(2)_"0)")) I %(3)]"",%(3)'="T" S %(2)=%(2)_%(3)_"," G Y
 S %(2)=%(2)_I,@(%(2)_")")="" Q
V2 S X=$O(^DD(S,F,"V",X)) Q:'X  S I=$P($G(^DD(S,F,"V",X,0)),U) G:'I V2
 S:'$D(Y("V"_X)) Y("V"_X)="" S %(2)="Y("_"""V"_X_"""," D Y
 D DTYP(.I,.01,.J)
 I J>0 S (Y("T"),Y("V"_X,"T"))=$S($G(J("T"))]"":J("T"),1:J) K J("T") S %X="J(",%Y=%(2)_"," D %XY^%RCR
 K %,J G V2

DIOZ
DIOZ ;SFISC/TKW - COMPILED SORT TEMPLATE ;11/29/94  09:53
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ENCU ;MARK A SORT TEMPLATE FOR ROUTINE COMPILATION
 I $G(DUZ(0))'="@" W !,$C(7),$$EZBLD^DIALOG(101) Q
EN1 N DDH,DIC,DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y,DIOZ
 D OS^DII:'$D(DISYS) I $G(^DD("OS",DISYS,"ZS"))="" W $C(7),!,$$EZBLD^DIALOG(820) Q
 D DIC Q:Y<0  S DIOZ=+Y
 S DIR(0)="Y"
 I $G(^DIBT(+Y,"ROU"))="" D  Q
 .D BLD^DIALOG(8029,$$EZBLD^DIALOG(8035),"","DIR(""A"")")
 .S DIR("B")="YES" D BLD^DIALOG(9014,"","","DIR(""?"")"),^DIR Q:'Y
 .S ^DIBT(DIOZ,"ROU")="^DISZ",^("ROUOLD")="DISZ"
 .W !!,$C(7),DIR("?",2),!,DIR("?")
 .Q
 S X(1)=$$EZBLD^DIALOG(8035),X(2)="DISZ" D BLD^DIALOG(8028,.X,"","DIR(""A"")")
 S DIR("B")="NO" D BLD^DIALOG(9019,"","","DIR(""?"")"),^DIR Q:'Y
 K ^DIBT(DIOZ,"ROU")
 W !!,$C(7),DIR("?",2),!,DIR("?")
 Q
 ;
DIC S DIC="^DIBT(",DIC(0)="AEIQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,""Compiled"""
 S DIC("S")="I '$P(^(0),U,8),Y'<1,$O(^DIBT(+Y,2,0))"
 D ^DIC Q
 ;
ENC ;CREATE COMPILED SORT ROUTINE
 D OS^DII:'$D(DISYS) I $G(^DD("OS",DISYS,"ZS"))="" D BLD^DIALOG(820) G QSV
 I $O(^TMP("DIBTC",$J,""))="" D BLD^DIALOG(1501) G QSV
 N %,%H,%I,DIROUT,DIRUT,DTOUT,DUOUT,DRN,I,J,K,X,Y,DIR
 D NEW G:$D(DIERR) QSV
 S K=2,I="" F  S I=$O(^TMP("DIBTC",$J,I)) Q:I=""  F J=0:0 S J=$O(^TMP("DIBTC",$J,I,J)) Q:'J  S X=^(J) I X]"" S K=K+1,^UTILITY($J,0,K)=X
 F I=1:1 S X=$P($T(TXT+I),";",3) Q:X=""  S K=K+1,^UTILITY($J,0,K)=X
 S X=$P(DIBTPGM,U,2) X ^DD("OS",DISYS,"ZS")
 K ^TMP("DIBTC",$J)
 Q
 ;
NEW I DIBTPGM'?1"^"1.7U1.4N D NXTNO(.DRN) Q:$D(DIERR)  S DIBTPGM=DIBTPGM_$E("000",1,(4-$L(DRN)))_DRN
 D NOW^%DTC,YX^%DTC
 K ^UTILITY($J,0)
 S ^UTILITY($J,0,1)=$P(DIBTPGM,U,2)_" ; GENERATED FROM '"_$P(^DIBT(DIBT1,0),U,1)_"' SORT TEMPLATE (#"_DIBT1_"), FILE:"_DP_",  USER:"_$S($G(^VA(200,+DUZ,0))]"":$P(^(0),U),1:$P($G(^DIC(3,+DUZ,0)),U))_" ; "_Y
 S ^UTILITY($J,0,2)=$T(DIOZ+1)
 Q
 ;
NXTNO(DRN) ; GET NEXT AVAILABLE ROUTINE NUMBER
 N DILOCK S DRN=0 D  Q:DRN
N1 . S DILOCK=0,DRN=$O(^DI(.83,"C","n",DRN)) Q:'DRN  D N3 G:DILOCK N1
N2 S DILOCK=0,DRN=$$NXTNO^DICLIB("^DI(.83,","","U") I DRN>9999 D BLD^DIALOG(1502) Q
 D N3 G:DILOCK N2
 Q
N3 L +^DI(.83,DRN,0):10 I '$T S DILOCK=1 Q
 S ^DI(.83,DRN,0)=DRN_"^y",^DI(.83,"B",DRN,DRN)="",^DI(.83,"C","y",DRN)="" K ^DI(.83,"C","n",DRN) L -^DI(.83,DRN,0) Q
 Q
 ;
ENRLS(DRN) ; MAKE ROUTINE NUMBER AVAILABLE FOR REUSE & DELETE ROUTINE
 N DICLEAN,X S DRN=+$G(DRN),DICLEAN='DRN G:DRN R1
R S DRN=$O(^DI(.83,DRN)) Q:'DRN
R1 I $G(^DI(.83,DRN,0))]"" S $P(^(0),U,2)="n",^DI(.83,"C","n",DRN)="" K ^DI(.83,"C","y",DRN)
 I $G(^%ZOSF("DEL"))]"" S X="DISZ"_$E("000",1,(4-$L(DRN)))_DRN X ^%ZOSF("DEL")
 G:DICLEAN R
 Q
 ;
QSV D:$G(DRN) ENRLS(DRN) K DIBTPGM
QER Q:$G(DIQUIET)
 D MSG^DIALOG("W") S DIERR=1 Q
 ;
 ;DIALOG #101    'only those with programmer's access'                 
 ;       #820    'no way to save routines on the system'               
 ;       #1501   'There is no code to save for this compiled...'
 ;       #1502   'All available routine numbers...are in use...'
 ;       #8028   '...currently compiled under namespace...'
 ;       #8029   '...not currently compiled.'
 ;       #8035   'Sort template'
 ;       #9014   (help) 'if YES...Sort logic will be compiled...'
 ;       #9019   (help) 'if YES...Sort logic...will NOT be compiled...' 
 ;
TXT ;;
 ;;M X $S($D(DPQ):DX(DIXX),1:^UTILITY($J,99,DIXX))

DIP
DIP ;SFISC/XAK,TKW-GET SORT SPECS ;1/18/95  14:35
 ;;21.0;VA FileMan;**2**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K %ZIS,BY,FLDS,DX,DIS,DISV,DHIT,DTOUT,DIFF D ^DICRW G Q:$D(DTOUT),EN:$D(DIC)
Q K DIJ,DIOEND,DIOBEG,DISTOP,DISTXT,DI,DICS,DJ,BY,A,DICSS,ZTSK,FR,TO,FLDS,DHD,DHIT,DIS,PG,DCOPIES,L,DISUPNO,DIPCRIT,DCC,DNP
 K %,%H,%I,%X,%Y,%DT,B,D0,DD,DIAC,DIFILE,DM,DP,DQ S I=$G(X) K X S:I]"" X=I
 D CLEAN^DIEFU
QQ K DIPR,DIBT,DIBT1,DIBT2,DIBTOLD,DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,DITYP,DINS,DIPT,DISX
 K S,DC,DL,DV,DE,DA,DK,DIFF,Y,R,C,D,I,J,Q,M,P,N,Q S:$D(DID) M=U Q
 ;
INIT S DIQUIET=1 Q:$D(ZTQUEUED)  I L!('$D(FLDS)#2)!($D(DIASKHD))!($G(IOP)="") K DIQUIET Q
 I $G(BY)="" K:$G(BY(0))="" DIQUIET Q
 N I,X F I=1:1 Q:'$G(DIQUIET)  S X=$P(BY,",",I) Q:X=""  K:X="@" DIQUIET D:$G(DIQUIET)
 . I $D(FR)#2 K:$P(FR,",",I)="?" DIQUIET I '$D(TO)#2 K DIQUIET Q
 . I $D(TO)#2 K:$P(TO,",",I)="?"!('$D(FR)#2) DIQUIET Q
 . I '$D(FR(I))#2!($G(FR(I))="?") K DIQUIET Q
 . I '$D(TO(I))#2!($G(TO(I))="?") K DIQUIET
 . Q
 Q
 ;
EN S L=1 N DIERR
EN1 ;
 S:DIC DIC=$G(^DIC(DIC,0,"GL")) G Q:DIC=""
 I "^DIA(^DDA("[$E(DIC,1,5),'$G(DIA) S DIA=+$P(DIC,"(",2) G Q:'DIA
 S:'$D(L)#2 L=0 N DIFM S DIFM=+L N DIFMSTOP D CLEAN^DIEFU I '$D(DIQUIET) N DIQUIET D INIT
 S DJ=1,U="^",(DCC,DI)=DIC,DNP="" D QQ I '$D(DISYS) N DISYS D OS^DII
 I $G(BY)="@" S %=$G(BY(0)),DNP=BY K BY S:%]"" BY(0)=% K %
 S:'$D(DTIME) DTIME=300
I ;
 G Q:'$D(@(DI_"0)")) S S=+$P(^(0),U,2)
 S Q="""",C=",",DC=0,DIJ=0,DE=$S(L=0!L!(L="]"):"SORT",1:L),DIL(S)=U
 I $D(BY(0)) D EN^DIP10 G Q:'$D(BY(0)) I $G(BY)="" S DPP=DPP(0) G N^DIP1
 F DJ=DJ:1 D DJ Q:X=""!($D(DTOUT))!($D(DUOUT))!'$D(DJ)  G FTEM^DIP1:X?1"[".E
 I $D(DUOUT)!($D(DTOUT))!('$D(DJ)) G Q
 G DUP^DIP1
DJ K DPP(DJ),DL,DV,I,J S I(0)=DI,(DL,J(0))=S,(N,DU)=0,Y=.01
 I DJ>1 S DIPR=$S($D(DIPR):DIPR,1:$P(DPP(DJ-1),U,3)),DV=$J("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY" D L^DIP0 K DIPR G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"
 I DJ>1 G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
 S P=$P(^DD(DL,.01,0),U,1,2)  D:'$D(DIPP) XR:$P(P,U,2)'["P"&($P(P,U,2)'["V") I 'DU S Y=S,DV(1)=$S($D(^DD(DL,.001,0)):$P(^(0),U),1:"NUMBER")
D1 S DPP(DJ)=$S($D(DIPP(DIJ)):DIPP(DIJ),1:Y_U_DU_U_DV(1)_U)
 S DV=DE_" BY" D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) I X="" D DJ^DIP1 Q
 G:$D(DIPP) ADD:X?1"^"1.E Q:X="@"
D K DPP(DJ,"IX"),DPP(DJ,"PTRIX") S R=U,P=DNP I X="]" S DXS=1,DJ=DJ-1 Q
Y I X'="NUMBER" D ^DIC K DUOUT G Q:$D(DTOUT)!(X=U) G G:Y>0,TEM^DIP11:X?1"[".E&'$D(DIPP),B:X=""
 F D="]","-","#","+","!","@","'" S Y=$F(X,D) I Y-1=$L(X)!(Y=2) S P=P_D,X=$E(X,1,Y-2)_$E(X,Y,999) S:D="]" DXS=1 G Y
 I X[";" S R=X,X=$P(X,";"),R=U_$P(R,X,2,9) G Y
 S D="NUMBER",Y=0_U_D I $P(D,X)="" W $P(D,X,2) G S
 G ^DIP0
 ;
BB S DPP(DJ,"F")=0,DPP(DJ,"T")=1,P=P_"@B",R=R_$S(R'[";L1":";L1",1:"") K DATE Q
G S X=$P(Y(0),U,2),D=$P($P(Y(0),U,4),";") G NM:'X
 S N=N+1,DPP(DJ,DL)=D,DIL(+X)=DL,I(N)=$S(+D=D:D,1:Q_D_Q),(DL,J(N))=+X,Y=.01_U_$P(^DD(DL,.01,0),U) I $D(DIPP(DIJ))#2 S %=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$S($D(DIPP(DIJ,DL)):DIPP(DIJ,DL),1:%)
 I $O(^DD(DL,0))>0!$S($D(BY):BY?1U.E1" ".E,1:0) S DV=$J("",DJ*2-2)_$P(^(0),U) D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"  G Y
NM D BB:X["B" I X["P"!(X["V") S P=P_Q_+Y,I=$P(Y,U,2),DPP(DJ)=DL_U_Y_U_P D DPQ^DIP1 S X="#"_$P(P,Q,$L(P,Q)),DPP=I G C^DIP0
 I +Y=.001 S Y=0_U_$P(Y,U,2),R=R_U_U_X
S ;
 S X=DL_U_+Y,DPP(DJ)=DL_U_Y_U_P_R I P'["-",R'[";TXT",$P(Y,U,3)="" D XR
 D DJ^DIP1 S:X'=U X=1 Q
B W $C(7),"??" Q:$D(DIJS)  G DJ
 ;
XR I $P($G(DPP(DJ)),U,3)="NUMBER",+DPP(DJ)=S,$P(DPP(DJ),U,2)=0 S DPP(DJ,"IX")=DI_DI_U_1 Q
 I 'Y S Y=+$P($P(DPP(DJ),U,4),"""",2) Q:'Y  D
 . N P,X,Z S Z=+$P($P(^DD(+DPP(DJ),Y,0),U,2),"P",2) G:'Z XER
 . D DTYP^DIOU(Z,.01,.P) G:P>4 XER S P=$P($G(^DD(Z,.01,0)),U,2) I P["O",P'[D G XER
 . F P=0:0 S P=$O(^DD(Z,.01,1,P)) Q:'P  I +^(P,0)=Z,$P(^(0),U,2,9)="B" Q
 . G:'P XER S P=$G(^DIC(Z,0,"GL")) G:P="" XER
 . S DPP(DJ,"PTRIX")=P_Q_"B"_Q_C Q
XER . S Y="" Q
 S P=$P($G(^DD(DL,+Y,0)),U,2) D
 . I P["O",P'["D" Q
 . I P?.E1"NJ"1.N1",2".E,$P($G(^DD(DL,+Y,0)),U,5,99)["""$""" Q
 . F P=0:0 S P=$O(^DD(DL,+Y,1,P)) Q:P'>0  I +^(P,0)=S S X=$P(^(0),U,2,9) I X?1A.AN S DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2,Y=+$O(^DD(S,0,"IX",X,-1)),DU=+$O(^(Y,-1)),DV(1)=$P(^DD(Y,DU,0),U) Q
 . Q
 I $D(DPP(DJ,"PTRIX")),'$D(DPP(DJ,"IX")) K DPP(DJ,"PTRIX")
 Q
ADD S X=$E(X,2,99),DIJS=DIJ,DIJ=0 D D I X=U!($D(DTOUT)) K DIJS Q
 S:$D(X) DJ=DJ+1 S DIJ=DIJS K DIJS G DJ

DIP0
DIP0 ;SFISC/XAK-COMPUTED FIELD ON A SORT, EDITING A SORT TEMPLATE ;12/23/94  08:25
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S P=P_Q,DPP=$P(X,U,1)
C ;
 S DICOMP=N_$E("?",''L),DM=X,DQI="Y(",DA="DPP("_DJ_",""OVF"_N_""",",DICMX="D M" G COLON:X?.E1":" D EN^DICOMP K DUOUT G X:'$D(X),X:Y["m" ;I Y["m" S X=DM_":" G C
 D XA,BB^DIP:Y["B" S:Y["D" R=R_"^^D" S Y=U_DPP,DPP(DJ,"CM")=X_" I D"_(N#100)_">0 S DISX("_DJ_")=X" G S^DIP
 ;
XA F %=0:0 S %=$O(X(%)) Q:%=""  S @(DA_"%)=X(%)")
 Q
 ;
 ;
COLON D ^DICOMPW K DUOUT
 I $D(X),$S($D(DIL(+DP)):DIL(+DP)=DL,1:1) S DPP(DJ,DL,+Y)=DP_U_(Y["m")_U_X,DIL(+DP)=DL,N=+Y,DL=+DP,DV=$J("",DJ*2-2)_$O(^DD(DL,0,"NM",0))_" FIELD" S:$D(DIPP(DIJ,+DP)) $P(DIPP(DIJ),U,3)=DIPP(DIJ,+DP) D XA,L G Y^DIP
X I $D(BY)#2,BY]"" S X=DM_C_BY,BY="" G C
 G B^DIP
 ;
EDT ;
 S DIE="^DIBT(",DR=".01;3;6",DA=X,DIPP=DI,DIOVRD=1 D ^DIE S DI=DIPP,DE=$S(L=0!L:"SORT",1:L) K DR,DIE,DIPP,DIOVRD I '$D(DA)!($D(Y)) S (X,DJ)=+$G(DPP(0)) Q
 S DIPP="",DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:'DJ  S DIJ=DIJ+1,%X="DPP(DJ,",%Y="DIPP(DIJ," D %XY^%RCR
 S DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:DJ=""  D
 . S DIJ=DIJ+1 N X S X=$P(DPP(DJ),U,4),X=$S(X[Q:$P(X,Q,($L(X,Q)-1)),1:X)
 . S $P(DIPP(DIJ),U,3)=X_$P(DPP(DJ),U,3)_$P(DPP(DJ),U,5)
 . S %=+DPP(DJ) D E1 S %X=0 D E2 K DPP(DJ)
 . Q
 S DJ=$G(DPP(0)),DIJ=0 F  S DIJ=+$O(DIPP(DIJ)) Q:'DIJ  S DJ=DJ+1 D DJ^DIP Q:$D(DTOUT)!($D(DIRUT))!('$D(DJ))  W:X="@" "  Deleted."
 K DIPP,DIJJ S:X'=U X=1 S:'$D(DXS) DXS=1 S DIEDT=1 Q
E1 ;
 F DIJJ=0:1 Q:'$D(^DD(%,0,"UP"))  S DIPP(DIJ,%)=$P(DIPP(DIJ),U,3),%=+^("UP"),$P(DIPP(DIJ),U,3)=$O(^("NM",0)),$P(DIPP(DIJ),U,1)=%
 Q
E2 S %X=$O(DPP(DJ,%X)) I %X'>0 K %X Q
 G E2:'$D(DPP(DJ,%X,100)) S %=%X D E1 S %=DPP(DJ,%X,100)
 I $P(%,U,3) S DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^DIC(+%,0),U)_":",$P(DIPP(DIJ),U)=+% G E2
 I %'["Y(1)" S %=$F(%,"OVF0") Q:'%  S %=+$E(DPP(DJ,%X,100),%+2,99),%=$P(DPP(DJ,%X,100),U)_U_DPP(DJ,"OVF0",%) Q:%'["Y(1)"
 S G=$P($P($P(%,"Y(1)",2),")):^(",2),")",1),P=$P(%,"Y(1)",3),P=$P($P(P,"U,",2),")",1),P=+$O(^DD(%X,"GL",G,P,0))
 I P,$D(^DD(%X,P,0)) S:DIJJ DIPP(DIJ,+%)=DIPP(DIJ,%X),DIPP(DIJ,%X)=$P(^(0),U)_":" S:'DIJJ DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^(0),U)_":"
 G E2
 ;
L I $D(BY)#2 K DIC S DIC="^DD(DL,",DIC(0)="Z",X=$P(BY,C,1),BY=$P(BY,C,2,99) I X'="@" K DV Q
 K DIR D
 . N X S DIR(0)="FO",DIR("A")=DV
 . S X=$P($G(DIPP(DIJ)),U,3) I X]"" S DIR("B")=X
 . I X="" S X=$G(DV(1)) I X]"" S DIR(0)="FOA",DIR("A")=DV_": "_X_"// "
 . S DIR(0)=DIR(0)_"^1:255",DIR("?")="^D DIC^DIP0"
 D ^DIR K DIR,DV,DIRUT,DIROUT S:$D(DTOUT) X="^"
 K:X?1"^"1.E DUOUT
 I X="@" K DPP(DJ) S DJ=DJ-1
 D SETDIC Q
 ;
SETDIC K DIC S DIC="^DD(DL,"
 S DIC("S")="S %=$P(^(0),U,2) I %'[""m"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W""&$S($D(DIL(+%)):DIL(+%)=DL,1:1))"_$S($D(DICS):" "_DICS,1:""),DIC("W")="W:$P(^(0),U,2) ""  (multiple)""",DIC(0)="ZE"_$E("O",$D(DIPP)#10) Q
 ;
DIC D SETDIC,^DIC,DIP^DIQQ Q

DIP1
DIP1 ;SFISC/GFT,TKW-PROCESS FROM-TO ;4/11/96  07:59
 ;;21.0;VA FileMan;**2,9,16,21**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D DJ Q
DUP D DPQ G DIP1^DIQQQ:$D(A(1))
 I '$D(BY),$D(DPP(2,"T"))!$D(DPP(3))!$D(DXS) S DK=S G S^DIBT
DIP2 S DC=0 D:'$D(DISYS) OS^DII G ^DIP2
 ;
FTEM I $G(DIBT1),$O(^DIBT(DIBT1,2,0)) D
 .I $D(DIBTOLD) D SNEW^DIBT Q
 .D US^DIBT Q
N ;
 S DCC=DI,C="," G DIP2
 ;
DPQ K A F X=1:1 Q:$D(DPP(X))#2=0  S A=$E($P(DPP(X),U,1,3),1,60),Y=$P(DPP(X),U,4),DPP=X S:Y'["'" (A($D(A(A))),A(A))=0 I Y'["@",Y'["'" S DPQ(+DPP(X),$P(Y,"""",2)+$P(DPP(X),U,2))=""
 K DPP(X) Q
 ;
DJ N DIFLD,DIFLDREG D DTYP I $D(DPP(DJ,"F")) D OPT^DIP12 Q
J ;
 S DC=$S($D(^DD(+DPP(DJ),$S(DIFLD:DIFLD,DIFLDREG="":U,1:.001),0)):$P(^(0),U,2,3),1:$P(DPP(DJ),U,7,8)),R=$P(DPP(DJ),U,3)
 K DIC,DIARE,DIARS N DIFRTO
S K DIERR,DPP(DJ,"SRTTXT")
 S DIPR=$P(DPP(DJ),";""",2,99),DIPR=$P(DIPR,"""",1,$L(DIPR,"""")-1),DIPR=$S(DIPR'="":DIPR,1:R),%=$E(DIPR,$L(DIPR)-1,$L(DIPR)),%=$S(%=": ":2,$E(%,2)=":":1,1:0) I % S DIPR=$E(DIPR,1,$L(DIPR)-%)
 S A="FIRST",DIFRTO="?" I 'L I $D(FR)#2!($O(FR(0))) S %="FR" D Z I DIFRTO'="?" G S0
 I $D(DISV) D FROM^DIARCALC
 K DIR S %="",%(1)=$G(DPP(DJ,"TXT")) S:%(1)="" %(1)=$G(DIPP(DIJ,"TXT")) S:%(1)]"" $P(%," ",(DJ+DJ-1))="",DIR("A",1)=%_"* Previous selection: "_%(1) K %
 S DIR(0)="FO^1:245",%="",$P(%," ",(DJ+DJ-1))="",DIR("A")=%_"START WITH "_DIPR,DIR("?")="^D DIP1F^DIQQ" S:A]"" DIR("B")=A
 D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DTOUT)!($D(DUOUT))
 I $G(DIR("B"))="FIRST",X="FIRST" S A="FIRST",X=""
 K DIR,DIRUT,DIROUT,DIERR
S0 I X="",A="FIRST" D:$P(DPP(DJ),U,5)[";TXT" STXT(DJ,"","",DITYP) D OPT^DIP12 Q
 S Y(0)="" D CK^DIP12:X'="" I X'="" I X'?.ANP!($D(DIERR)) G:DIFRTO="?" S G Q
 S M=1 D PAR
 D FRV
 S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S (B,DPP(DJ,"F"))=Y
T K DIERR S Y="z",A="LAST",DIFRTO="?" I 'L I $D(TO)#2!($O(TO(0))) S %="TO" D Z I DIFRTO'="?" G T0
 I $D(DISV) D TO^DIARCALC
 G T0:$G(DIAR)=4
 K DIR S %="",$P(%," ",(DJ+DJ-1))="",DIR(0)="FO^1:245",DIR("A")=%_"GO TO "_DIPR,DIR("?")="^D DIP1T^DIQQ" S:A]"" DIR("B")=A
 D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DUOUT)!($D(DTOUT))
 I X="LAST",$G(DIR("B"))="LAST" S X="",Y="z"
 K DIR,DIRUT,DIROUT,DIERR
T0 S Y(0)="" I DITYP=1,X]"" D
 . Q:X="@"  I X?1.U,$E(X)'="T" Q
 . N I,D S I=$S(X["@":"@",X[".":".",1:""),D=$G(DITYP("D"))
 . I I]"",$P(X,I,2)]"" Q:D["T"!(D["S")
 . S:I]"" X=$P(X,I) I D'["T",D'["S" Q
 . S X=X_"@2400" Q
 D STXT(DJ,B,"^"_X,DITYP)
 I $D(DPP(DJ,"SRTTXT")) S:$G(DPP(DJ,"F"))]"" B=DPP(DJ,"F")
 D:X]"" CK^DIP12 I $D(DIERR) G:DIFRTO="?" T G Q
 S M=2 D PAR:Y'="z"
 S:$D(DPP(DJ,"SRTTXT")) Y=$P(" ",U,(X'="@"))_Y S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S DPP(DJ,"T")=Y
 I B["?z"!($P(Y,U)="@") D OPT^DIP12 Q
 I $$BEF^DIU5($P(Y,U),$P(B,U)) D:'$G(DIQUIET) FER1^DIQQ G:DIFRTO="?" T G Q
 D OPT^DIP12 Q
 ;
FRV N M I +$P(Y,"E")=Y S Y=Y-$S(Y:.00001,$P(DPP(DJ),U,2)'=0&$L(DC):1,1:0) Q
 F %=$L($E(Y,1,30)):-1:1 S M=$A(Y,%) I M>32 S Y=$E(Y,1,%-1)_$C(M-1)_$C(122) Q
 Q
 ;
DTYP N S S DIFLDREG=$P(DPP(DJ),U,2),DIFLD=DIFLDREG+$P($P(DPP(DJ),U,4),"""",2) I 'DIFLD,DIFLDREG'="" S DIFLD=.001
 S S=$P(DPP(DJ),U)
D1 K DITYP S DITYP=""
 I S,DIFLD D DTYP^DIOU(S,DIFLD,.DITYP) I $G(^DD(S,DIFLD,2))]"",DITYP'=1 S DITYP=4
 I DITYP=6,$G(DITYP("T"))=1 S DITYP("D")="TS"
 S:$G(DITYP("T")) DITYP=DITYP("T")
 I DITYP="",'DIFLD,$P(DPP(DJ),U,7)]"" D
 . N I,X S X=$P(DPP(DJ),U,7),I=""
 . F  S I=$O(^DI(.81,"C",I)) Q:I=""  I X[I S DITYP=$O(^(I,0)) Q
 . S:DITYP=1 DITYP("D")="TS"
 . Q
 S:'DITYP DITYP=4
DTYPQ S $P(DPP(DJ),U,10)=DITYP Q
 ;
Q K DITYP,DIERR,DIR S:$D(DTOUT) X="^" G Q^DIP
 ;
PAR S M=$P($P($P($P(DPP(DJ),U,5),";P",2),";",1),"-",M)
 I M]"",M?.ANP S DIPA($E(M,1,30))=Y
 Q
 ;
Z I %="FR" S X=$S($D(FR)#2:$P(FR,C,DJ),$D(FR(DJ))#2:FR(DJ),1:"?")
 I %="TO" S X=$S($D(TO)#2:$P(TO,C,DJ),$D(TO(DJ))#2:TO(DJ),1:"?")
 I X'="?" S DIFRTO=""
 Q
 ;
STXT(DJ,F,T,DITYP) ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT.
 K DPP(DJ,"SRTTXT") Q:"3,4"'[DITYP
 N F2,T2 S F2=$P(F,U,2),T2=$P(T,U,2)
 I F2]"" Q:F2=T2  Q:($E(F2,1)?1A)&($E(T2,1)?1A)  I F2?1.N.1".".N,T2?1.N.1".".N Q:+F2'=F2&(+T2'=T2)
 I $P($G(DPP(DJ)),U,5)[";TXT" S DPP(DJ,"SRTTXT")="SORT" G N2
 Q:+$E(F2,"E")=F2&(+$E(T2,"E")=T2)
 I F2?1.N.1".".N,+F2'=F2 S DPP(DJ,"SRTTXT")="RANGE"
 I T2?1.N.1".".N,+T2'=T2 S DPP(DJ,"SRTTXT")="RANGE"
N2 Q:'$D(DPP(DJ,"SRTTXT"))
 K DPP(DJ,"IX"),DPP(DJ,"PTRIX")
 I F]"",$P(F,U)'="?z",$G(DPP(DJ,"F"))]"" N Y D  S DPP(DJ,"F")=Y_U_$P(F,U,2,3)
 . S Y=$P(F,U) I F2]"" S Y=" "_F2 D FRV
 . Q
 Q:$G(DPP(DJ,"T"))=""!("@"[$P(T,U))
 S DPP(DJ,"T")=$S($P(T,U,2)]"":" "_$P(T,U,2)_U_$P(T,U,2,3),1:T) Q

DIP10
DIP10 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES ;12/5/94  14:10
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N I,J,K,X,Y,DIR I $G(BY(0))="" D BLD^DIALOG(201,"BY(0)")
 I $E(BY(0))'="[" D  I Y=-1 D BLD^DIALOG(201,"BY(0)")
 . N %,X S X=BY(0),Y="" I X'["(" S:X[")"!(X[",") Y=-1 Q:Y=-1  S X=X_"("
 . S:$E(X)'=U X=U_X
 . S %=$E(X,$L(X)) S:%=")" $E(X,$L(X))=",",%="," I ",("'[% S X=X_","
 . I $O(@(X_""""")"))="" S Y=-1 Q
 . S BY(0)=X Q
 I $E(BY(0))="[" D  I Y'<0 S BY(0)="^DIBT("_+Y_",1,",L(0)=1
 .N DIC,DIBTFILE,DJ,DCC,DI,DNP,L S DIBTFILE=S N S
 .S X=$P($E(BY(0),2,99),"]"),DIC="^DIBT(",DIC(0)="Q",DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DIBTFILE,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$O(^(1,0))"
 .D ^DIC
 .I Y<0 S I(1)=BY(0) D BLD^DIALOG(1500,.I)
 .Q
 I '$G(L(0)) D BLD^DIALOG(201,"L(0)")
 S I=BY(0),X="" D  K I,X I '$D(L(0)) D BLD^DIALOG(201,"L(0)")
 . N J F J=1:1:L(0) S X=$O(@(I_""""")")) S:X]"" X=$S(+$P(X,"E")'=X:$$QUOTE^DILIBF(X),1:X),I=I_X_"," I X="" K L(0) Q
 . Q
 G:$D(DIERR) EX
 S DPP(0)=L(0)-1 K DPP(0,"TXT"),DISTXT
 S J=8004 I BY(0)?1"^DIBT("1.N1",1," S J=+$P(BY(0),"^DIBT(",2) D ENT(0,J) S J=8003
 I '$D(DISTXT) S I(1)=$S($E(BY(0),$L(BY(0)))=",":$E(BY(0),1,($L(BY(0))-1))_")",1:BY(0)) D BLD^DIALOG(J,.I,"","DIR") S DPP(0,"TXT")=DIR
 F I=1:1:L(0)-1 S DPP(I)=S_"^^SORT FIELD "_I_"^""@^^^^^^4",DPP(I,"SER")="999^999",J="",$P(J,"D",L(0)-I+1)="",(DPP(I,"GET"),DPP(I,"CM"))="S DISX("_I_")="_J_"D0"
 S DPP(0,"IX")=$E(U,$E(BY(0))'=U)_BY(0)_DCC_U_$S($D(L(0)):L(0),1:1)
 F I=0:0 S I=$O(FR(0,I)) Q:'I  I $D(DPP(I)) S (Y,K)=FR(0,I) D:Y]"" FRV^DIP1 S DPP(I,"F")=Y_U_K S:I=1 DPP(0,"F")=Y_U_K
 F I=0:0 S I=$O(TO(0,I)) Q:'I  I $D(DPP(I)) S DPP(I,"T")=TO(0,I)_U_TO(0,I)
 F I=0:0 S I=$O(DISPAR(0,I)) Q:'I  D
 .S X="""",J=$P(DISPAR(0,I),U) F K="!","#","+","@" I J[K S X=X_K
 .I X'["@",$P(DISPAR(0,I),U,2)'[";""" S X=X_"@"
 .S $P(DPP(I),U,4)=X S $P(DPP(I),U,5)=$P(DISPAR(0,I),U,2)
 .I $G(DISPAR(0,I,"OUT"))]"" S DPP(I,"OUT")=DISPAR(0,I,"OUT")
 .Q
 I $D(FR)#2!($D(TO)#2) S J="",$P(J,",",L(0))="" S:$D(FR)#2 FR=J_FR S:$D(TO)#2 TO=J_TO G ENX
 S J=$O(FR(8),-1) I J F J=J:-1:0 I $D(FR(J))#2 S FR(J+DPP(0))=FR(J) K FR(J)
 S J=$O(TO(8),-1) I J F J=J:-1:0 I $D(TO(J))#2 S TO(J+DPP(0))=TO(J) K TO(J)
ENX S DJ=L(0) K DISPAR(0),L(0),FR(0),TO(0)
 Q
 ;
ENT(I,J) ;MOVE TEXT OF SEARCH AND GET CODE FROM SEARCH TEMPLATE TO DPP ARRAY
 ;I=Entry no.in DPP array, J=record number for search template
 Q:$G(I)=""  Q:'$G(J)  N DIR,%X,%Y
 D BLD^DIALOG(8003,$P($G(^DIBT(J,0)),U),"","DIR") D:$O(^DIBT(J,"O",0))  S DISTXT(99,0)=DIR
 . S %X="^DIBT("_J_",""O"",",%Y="DISTXT(" D %XY^%RCR
 . S DIR="("_DIR_")" Q
 S:I DPP(I,"GET")="S DISX("_I_")=D0"
 Q
 ;
EX K BY(0),L(0) Q:$G(DIQUIET)
 D MSG^DIALOG("W") Q
 ;DIALOG #201    'The input variable...is missing or invalid.'
 ;       #1500   'Search template...in BY(0) variable cannot be found...'
 ;       #8003   'Records from list on...search template.
 ;       #8004   'Sort using...'

DIP11
DIP11 ;SFISC/XAK,TKW-GET SORT TEMPLATE ;4/11/96  08:01
 ;;21.0;VA FileMan;**2,9,16,21**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
TEM ;
 I DJ-1 G B^DIP:$G(BY(0))="" I DJ>(DPP(0)+1) G B^DIP
 K DIC F %=DJ:0 K DPP(%) S %=$O(DPP(%)) Q:'%
 S X=$P($E(X,2,99),"]",1),DIC(0)="ZQS"_$E("E",'($D(BY)#2)!''L),DIC="^DIBT(",D="F"_DL
 S DIC("S")="I $P(^(0),U,4)=DL,$S(L=0:1,'$D(^(1)):1,'$P(^(0),U,5):1,1:$P(^(0),U,5)=DUZ)"
 I X?."?" S:X'?1"???" X="??" D IX^DIC S DJ=$G(DPP(0)) Q
 D ^DIC I Y<0 S DJ=$G(DPP(0)) Q
 I $D(^DIBT(+Y,"DIS")),'$D(^(1)) W:'$G(DIQUIET) !,"This SEARCH template has no search results!" S DJ=$G(DPP(0)) Q
 S DPP(DJ)=DL_"^^'"_$P(Y,U,2)_"' NUMBER^@'"_P,(DIBT1,X)=+Y,DIBT2=$P(Y(0),U),D=DIC_X_C K DIC
 I '$D(FLDS),$G(^DIBT(X,"DIPT"))]"" S FLDS="["_^("DIPT")_"]" I L D
 . N %,A S %(1)=^("DIPT") D BLD^DIALOG(8030,.%,"","A") W ! F %=0:0 S %=$O(A(%)) Q:'%  W A(%),!
 . S L=0 Q
 I $D(^DIBT(X,1)) S DIC=D_1_C,DPP(DJ,"SER")="998^998" D ENT^DIP10(DJ,DIBT1) I $D(^DIBT(X,1)) S Y=1 D
 .F DY=1:1 S Y=$O(^(Y,-1)) S:Y="" Y=-1 S:$O(^(Y)) Y=$O(^(Y)) I $D(^(Y))<9 S DPP(DJ,"IX")=DIC_DI_U_DY,DIBT=X Q
 .Q
ENDIPT Q:'$D(^DIBT(X,2))  I $G(^DIBT(X,2,0))="" S %Y="DPP(",%X=D_2_C D %XY^%RCR S DIBTOLD="" D CNVCM G T0
 F D=0:0 S D=$O(^DIBT(X,2,D)) Q:'D  D
 .N A,B,C S DPP(DJ)=^DIBT(X,2,D,0)
 .S A="A" F  S A=$O(^DIBT(X,2,D,A)) Q:A=""  I A'="SER" S DPP(DJ,A)=^(A)
 .F B=1,2,3 F A=0:0 S A=$O(^DIBT(X,2,D,B,A)) Q:'A  S C=$G(^(A,0)) D
 ..I B=1 S:$P(C,U)=+C DPP(DJ,+C)=$P(C,U,2) Q
 ..I B=2 S:($P(C,U)=+C)&($P(C,U,2)=+$P(C,U,2)) DPP(DJ,+C,$P(C,U,2))=$P(C,U,3,7)_U_$G(^DIBT(X,2,D,2,A,"RCOD")) Q
 ..I $P(C,U,1)]"",$P(C,U,2)]"" S DPP(DJ,$P(C,U,1),$P(C,U,2))=$G(^DIBT(X,2,D,3,A,"OVF0"))
 ..Q
 .S DJ=DJ+1 Q
T0 Q:$D(DIBTRPT)
 I $D(DIAR) S DIARU=X ;I '$P(DIARB,U,2) S $P(DIARB,U,2)=DIARU
 F D=0:0 S D=$O(^DIBT(X,3,D)) Q:D=""  S DSC(D)=^(D)
 G T1:'L S %=$P(^DIBT(X,0),U,6)
 I %]"" F D=1:1:$L(%) I DUZ(0)[$E(%,D)!(DUZ(0)="@") S %="" Q
 I %="",X'<1 S %=$P(Y(0),U,1) D  G Q:$D(DIRUT) I %=1 K DIBTOLD G EDT^DIP0
 . N X,Y K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="WANT TO EDIT '"_%_"' TEMPLATE" D ^DIR K DIR
 . S %=Y Q
T1 F DJ=$G(DPP(0))+1:1 Q:'$D(DPP(DJ))  D  I '$D(DJ)!($D(DTOUT))!($D(DIRUT)) G Q
 . N DL,DU,DV,X,Y,Z,DIFLD,DIFLDREG K DPP(DJ,"PTRIX") S DL=$P(DPP(DJ),U),Y=$P(DPP(DJ),U,2,3)
 . D DTYP^DIP1,STXT^DIP1(DJ,$G(DPP(DJ,"F")),$G(DPP(DJ,"T")),DITYP)
 .; Save off old "IX" node to preserve it if template is hand-edited.
 . I DJ=1 N DISAVIX,DIRECSRT S DISAVIX=$G(DPP(DJ,"IX")),DIRECSRT=0
 . K DPP(DJ,"IX")
 . I $P(DPP(DJ),U,4)'["-",'$D(DPP(DJ,"SRTTXT")),$P($G(DPP(DJ,"F")),U)'="?z",$P($G(DPP(DJ,"T")),U)'="@" D XR^DIP I DJ=1,DISAVIX]"",DISAVIX'=$G(DPP(DJ,"IX")) D
 .. N I,X,Y,Z S X=$P(DISAVIX,U,3),Z=$P(DISAVIX,U,2) I $E(Z,1,$L(X))'=X S DIRECSRT=1 G T12
 .. S Z=$E(Z,($L(X)+1),99),Z=$P(Z,"""",2) Q:Z=""  I '$D(^DD(S,0,"IX",Z)) D  Q:Z=""
 ... Q:S=405&(Z="ATT3")  S Z="" Q
T12 .. S DPP(DJ,"IX")=DISAVIX,DPP(DJ,"SER")="998^998"
 .. I DIRECSRT=1,$P(DPP(DJ),U,2)="",'($P($P(DPP(DJ),U,4),"""",2)),'$D(DPP(DJ,"CM")) S $P(DPP(DJ),U,2)=0
 .. Q
 . I $D(DPP(DJ,"ASK")) S DPP(DJ,"ASK")=1 I $G(DICNVDPP)'=1 K DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE D J^DIP1 Q
 . I DJ=1,DISAVIX=1 Q
 . D OPT^DIP12 Q
 Q:$G(DICNVDPP)=1
 D DPQ^DIP1 S X="["_DIBT2 K DIARE,DIARS,DIARB Q
 ;
CNVCM ;Convert V20 DPP array to V21 DPP array (for prints queued in V20 to run in V21)
 N D,I,J,X,Y,Z,N
 F D=0:0 S D=$O(DPP(D)) Q:'D  S X=$G(DPP(D,"CM")) I X["S X(" D
 . S (I,Z)=0 F  S Y=$F(X,"S X(",Z) Q:'Y  S Z=Y,I=I+1
 . Q:'Z  S N=+$E(X,Z) Q:'N
 . I $L(X)+16>248 D  Q
 .. S Z="OVF",I=-1 F  S Z=$O(DPP(D,Z)) Q:$E(Z,1,3)'="OVF"  S I=$E(Z,4,99)
 .. S Z="OVF"_(I+1),Y=$P(X," S X=",1) S:Y]"" Y=Y_" "
 .. S DPP(D,"CM")=Y_"X DPP("_D_","""_Z_""",9.2) I $G(X("_N_"))]"""" S DISX("_N_")=X("_N_")"
 .. S Y=$P(X," S X=",2,99),DPP(D,Z,9.2)=$P("S X=",U,(Y]""))_Y Q
 . S DPP(D,"CM")=$P(X,"S X(",1,I)_"S DISX("_$P(X,"S X(",I+1,99)
 . Q
 Q
 ;
Q S:$D(DUOUT)!($D(DTOUT)) X="^" G Q^DIP
 ;DIALOG #8030  'Because...sort template...linked w/Print template...

DIP12
DIP12 ;SFISC/TKW-PROCESS FROM-TO (CONT.) ;7/28/95  14:15
 ;;21.0;VA FileMan;**2,9,16**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
OPT ;Build code to extract field & test sort criteria, build sort description.
 N S,F,X,%,F1,F2,F3,T1,T2,T3,N,DIRANGE
 S S=$P(DPP(DJ),U),F=$P(DPP(DJ),U,2),N=$P(DPP(DJ),U,3) S:N["""" N=$$CONVQQ^DILIBF(N),DIRANGE=""
 S X="DISX("_DJ_")",DPP(DJ,"GET")=""
 I +$P(S,"E")=S,F D GET^DIOU(S,F,X,.%) S DPP(DJ,"GET")=%
 I $D(DPP(DJ,"CM")) S DPP(DJ,"GET")=DPP(DJ,"CM")
 I $G(DPP(DJ,"SRTTXT"))="SORT" S DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"="_""" ""_"_X
 I +$P(S,"E")=S,F,$P(DPP(DJ),U,10)=2 D
 . N % S %=$P($G(^DD(S,F,0)),U,2) I %'["C",%'["N" Q
 . S DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"=+"_X
 . Q
 I $P(DPP(DJ),U,4)["@B" S %=X,DPP(DJ,"TXT")=N G O2
 I S,F=0 D BIJ^DIOU(S,.01,.%,.F) S X="D"_$G(%(S)) K %,F
 I '$D(DPP(DJ,"F")) S %=$$NULL^DIOC(X,"'"),DPP(DJ,"TXT")=N_" not null" G O2
 S %=$G(DPP(DJ,"F")),F1=$P(%,U),F2=$P(%,U,2),F3=$P(%,U,3) S:F3="" F3=F2 S:$E(F1,1)="""" F1=""""_F1
 S %=$G(DPP(DJ,"T")),T1=$P(%,U),T2=$P(%,U,2),T3=$P(%,U,3) S:T3="" T3=T2
 S DIRANGE="" S:$G(DPP(DJ,"SRTTXT"))="RANGE" DIRANGE=""" ""_"
 S %=""
 I F1="?z" D  G O2
 . I T1="z" S %="1",DPP(DJ,"TXT")="All "_N_" (includes nulls)" Q
 . I T1="@" S %=$$NULL^DIOC(X),DPP(DJ,"TXT")=N_" is null" Q
 . S %=$$AFT^DIOC(DIRANGE_X,T1,"'")
 . S DPP(DJ,"TXT")=N_$S(T3]"":" to "_T3,1:"")_" (includes nulls)"
 . Q
 S DPP(DJ,"TXT")=N_$S(F3]"":" from "_F3,1:"")
 I T1="@"!(T1="z") D  G O2
 . S %="" I T1="@" S DPP(DJ,"TXT")=DPP(DJ,"TXT")_" (includes nulls)",%=$$NULL^DIOC(X)_"!("
 . S %=%_$$AFT^DIOC(DIRANGE_X,F1) S:T1="@" %=%_")"
 . Q
 I F3]"",F3=T3 S %=$$EQ^DIOC(X,T1),DPP(DJ,"TXT")=N_" equals "_F3 G O2
 S %=$$BTWI^DIOC(DIRANGE_X,F1,T1,"","SORT")
 I T3]"" S DPP(DJ,"TXT")=DPP(DJ,"TXT")_" to "_T3
O2 S DPP(DJ,"QCON")="I "_%
 K DITYP Q
 ;
CK ;VALIDATE FIELDS/DATA
 G QQ:X[""""!(X[U) I X="@" S Y=X K DPP(DJ,"IX"),DPP(DJ,"PTRIX") Q
 I DITYP=1 S %DT="" D  D ^%DT K %DT G:Y=-1 QQ S Y(0)=$$FMTE^DILIBF(Y,2) Q
 . S:$G(DITYP("D"))["T" %DT="T"
 . S:$G(DITYP("D"))["S" %DT=%DT_"S"
 . S %DT=%DT_$E("E",(DIFRTO="?")) Q
 I DITYP=3 D  G:Y=-1 QQ Q
 . S Y=$G(DITYP("S","E",X)) I Y]"" S Y(0)=Y_" ("_X_")" W:DIFRTO="?" "    USES INTERNAL CODE: "_Y Q
 . I $D(DITYP("S","I",X)) S Y=X,Y(0)=X_" ("_DITYP("S","I",X)_")" W:DIFRTO="?" "  "_DITYP("S","I",X) Q
 . S D=$O(DITYP("S","E",X)) I D]"",$P(D,X)="" S Y=DITYP("S","E",D),Y(0)=Y_" ("_D_")" W:DIFRTO="?" $P(D,X,2,9)_"    USES INTERNAL CODE: "_Y Q
 . I DIFRTO'="?" S Y=X Q
 . S Y=-1 Q
 I +$P(X,"E")=X!(DITYP'=2) S Y=X Q
QQ S Y=-1,DIERR="Invalid Entry" Q:$G(DIQUIET)
 W $C(7),"??",DIERR Q

DIP2
DIP2 ;SFISC/GFT-PRINT FLDS OR TEMPLATES ;2/10/94  09:48
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY("DIP2",$J),DG,K,DISH,DIL,DXS,A,P,I,J S I(0)=DI,(DE,DINS,DV,DNP)="",(DXS,DL,R)=1,(DIPT,DJ,DCL,DIL)=0,DK=+$P(@(DI_"0)"),U,2),J(0)=DK
EN ;
 ;I $D(DIAR),'$D(DIARP(DIARF)) G DIP2^DIARA:DIAR=1 D DIP2^DIARA
F S (P,S)=""
1 ;G B:DC,B:DE'="",B:'$D(FLDS)
 ;S DC=0,(X,DU)=FLDS
 ;G ^DIP21
B S DU=$P(^DD(DK,0),U) I DL>1 S:DU="FIELD" DU=$O(^(0,"NM",0))_" "_DU I $O(^($O(^DD(DK,0))))'>0,$P(^(.01,0),U,2)["W" S:'DINS&DC DC=DC-2 S Y=.01 D P G N
 K DIC,Y K:$D(DALL)<9 DALL I ('L!($G(DDXP)=4)),$D(FLDS) S X=$P(FLDS,C,R),R=R+1 G LIT
 I DC D ^DIP22:'$D(DC(DC))
2 W !?DL+DL-2,$S(DE]""!($D(DJ)>9):"THEN",1:"FIRST")_$S($G(DDXP)=2:" EXPORT ",1:" PRINT ")_DU_": "
 I DC W DC(DC) D RW G Q^DIP:X=U!($D(DTOUT)) S DINS=X?1"^"1E.E,X=$S(DINS:$E(X,2,999),X="":DC(DC),1:X) S:DC(DC)=""&$L(X) DINS=1 G XPCK
 I $D(DIRPIPE) X DIRPIPE G LIT
 R X:DTIME S:'$T X=U G Q^DIP:X=U
 I X="ALL",DE="",$D(DJ)<2 D  G:$D(DIRUT) Q^DIP D:Y&($G(DDXP)=2) VALALL^DDXP2 G N:Y,F:'$D(X) W !?10,X
 . S DIR(0)="YA",DIR("A")="  Do you mean ALL the fields in the file? ",DIR("B")="NO",DIR("?")="Choose YES for every field in the file; NO for a field starting with 'ALL'",%XX=X
 . D ^DIR S X=%XX K DIR,%XX S:$D(DIRUT) X=U Q
XPCK I $G(DDXP)=2 D VAL1^DDXP2 G:'$D(X) F
LIT I $E(X)="""",$L(X,"""")#2 F A9=3:2:$L(X,Q) Q:$P(X,Q,A9)]""&($E($P(X,Q,A9)'=$C(95)))
 I  I $P($P(X,Q,A9),";")="" K A9 S S=X G S:DINS,S:'$D(DIAR),S:DIAR'=4,S:'$D(DC(DC)),S:DC=0,Z^DIP22
 S DIC="^DD(DK,",DIC(0)=$E("ZE",1,'$D(FLDS)!''L+1)_$E("O",1,DC>0),DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":""  (word-processing)"",1:""  (multiple)"")" S:$D(DICS) DIC("S")=DICS
DIC G DIC^DIP22
RTN I DC,X="@" D DC G F
 G DIP2^DIQQ:X?."?",Q^DIP:X=U I $P("NUMBER",X,1)="" W $P("NUMBER",X,2) S S=0_S G S
 S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)) D IX^DIC G GF:Y>0 I 'Y F Y=0:0 S Y=$O(Y(Y)) G F:Y="" S X=^DD(DK,Y,0) D Y
 G HARD^DIP22
 ;
GF I $G(DDXP)=2 D VAL2^DDXP2 G:'$D(Y(0)) F
 I $P(Y(0),U,2) D D,DC:DC S X=$P($P(Y(0),U,4),";",1),I(DIL)=$S(+X=X:X,1:Q_X_Q),J(DIL)=DK G 1
 I +Y=.001 S Y=0
 S S=+Y_S I P]"",$D(DCL(DK_U_+Y)) G QQ^DIP22
S I $G(DDXP)=2 D VAL3^DDXP2 G:'$D(S) F
 D DJ G F
 ;
D S DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+$P(^DD(DK,+Y,0),U,2),DL=DL+1,DIL=DIL+1,DV=DV_+Y_C,Y=0 Q
 ;
U S DL=DL-1,DV=DV(DL),DK=DL(DL),DIL=DIL(DL) F %=DIL:0 S %=$O(I(%)) Q:%=""  K I(%),J(%)
 Q
 ;
DC I 'DINS K:DC>1 DC(DC) S DC=DC+1
 Q
 ;
Y S S=Y_S
DJ I $L(DE)+$L(S)>150 S DJ=DJ+1,^UTILITY("DIP2",$J,DJ)=DE,DE=""
 S DE=DE_DV_S_$C(126),S="" D DC:DC
P Q:'$D(P)  I P="" K DNP Q
 I P="*" S DCL=DCL+1
 S DCL(DK_U_+Y)=$S($T:DCL_P,1:P) Q
 ;
N S I=DL S:I=1 DALL=1
NN S Y=.001 I $D(^DD(DK,Y)) S Y=0 D Y S Y=.001
A S Y=$O(^DD(DK,Y)) I Y,$D(^(Y,8)),$D(DICS) X DICS E  G A
 I Y'>0 G UP:I'<DL S Y=$P(DV,C,DL-1) D U G A
 I $P(^(0),U,2) D D G NN
 D Y G A
 ;
UP K DIC I DL>1 D U,DC:DC G F
 I DE="",'DJ,'$D(DHIT),'$D(DIS) G F
 I $D(FLDS)>9 S X=$O(FLDS("")) I X]"" S FLDS=FLDS(X),R=1 K FLDS(X) G F
 G ^DIP3
 ;
RW I $L(DC(DC))>19 S Y=DC(DC) D RW^DIR2 Q
 W "// " R X:DTIME S:'$T X=U,DTOUT=1 Q
 ;
ER S (X,DU)="[CAPTIONED]" G ^DIP21

DIP21
DIP21 ;SFISC/XAK-PRINT TEMPLATE ;9/29/94  08:41
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D D S DIC(0)=$E("E",'$D(FLDS)!''L)_"QZSI"
 S DIC("S")="I $D(^(""F""))"_$S($G(DIAR)=4:",$D(^(1))",$G(DDXP)=2:",$P(^(0),U,8)=7",$G(DDXP)=4:",$P(^(0),U,8)=3",1:"")_" "_DIC("S") S:$G(DDXP)=4 DIC("W")=""
 D IX^DIC K DIC S:(+Y=.01&(DUZ(0)'="@")) DICSS=$$ACC(8) I Y<0 G Q^DIP:$D(DTOUT),^DIP2:L,^DIP2:'$D(FLDS),Q^DIP
 I L,+Y=.01 K DPQ(DK) S DIQ(0)="" D C^DII G:$D(DIRUT) Q^DIP
 I L,Y'<1,(('$P(^DIPT(+Y,0),U,8))!($G(DDXP)=2&($P(^DIPT(+Y,0),U,8)=7))) D W:DUZ(0)'="@" I  S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' TEMPLATE" D YN^DICN G ED^DIP23:%=1
 K:'$D(^("DNP")) DNP S DIPT=+Y,DALL=1,DHD=$S($D(DHD)#2:DHD,$D(^("H")):^("H"),1:""),DC(0)=+Y I $D(^("SUB")),^("SUB") S DISH=1
 D F I $G(^DIPT(+Y,"ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) S DIPZ=+Y G PAGE^DIP3:DHD="@"
 Q:$D(DTOUT)  G H^DIP3
F ;
 S DE="",R=0
 F X=0:0 S R=$O(^DIPT(+Y,"DCL",R)) Q:R=""  F D=1:1 Q:D>$L(^(R))  S Z=$E(^(R),D) I Z?1P S DCL(R)=$G(DCL(R))_Z
 F X=0:0 S X=$O(^DIPT(+Y,"DXS",X)),%=-1 Q:X=""  Q:$O(^(X,%))=""  I '$D(DIPZ)!$D(^(9.2))!$D(^(9)) F X=X:0 S %=$O(^(%)) Q:%=""  S DXS(X,%)=^(%)
 Q
XPUT ;
 D XPDIP21^DIQQQ
PUT ;
 D NOW^%DTC S DIPDT=+$J(%,0,4) W !,"STORE "_$S($G(DDXP)=2:"EXPORT",1:"PRINT")_" LOGIC IN TEMPLATE: " R X:DTIME G Q^DIP:X=U!'$T,XPUT:($D(DDXP)&(X="")),OUT:X=""
 D D S DIC(0)="ELZSQ",DIC("S")="I Y'<1,$P(^(0),U,8)'=1,$P(^(0),U,8)'=3 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q^DIP
 S S=$O(^DIPT(+Y,0)),DA=$S('$D(^("ROU")):1,^("ROU")'[U:1,'$D(^("IOM")):1,'$D(^("ROUOLD")):1,1:^("ROUOLD")) S:'DA IOM=^("IOM")
 I S]"" W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 L +^DIPT S %Y="" F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y=""  K:",%D,ROUOLD,W,"'[(","_%Y_",") ^DIPT(+Y,%Y)
 S ^DIPT("F"_J(0),$P(Y,U,2),+Y)=1,^DIPT(+Y,0)=$P(Y,U,2)_U_DIPDT_U_$S(S!(S=""):DUZ(0),1:$P(Y(0),U,3))_U_J(0)_U_DUZ_U_$S(S!(S=""):DUZ(0),1:$P(Y(0),U,6))_U_DT S:DHD]"" ^("H")=DHD S:$D(DNP) ^("DNP")=1 S X=$D(^("DCL",0)) L -^DIPT K DIPDT,%I
 F S=0:0 S X=$O(DCL(X)) Q:X=""  S ^(X)=DCL(X)
 F S=0:0 S S=$O(DXS(S)) Q:S=""  F %=0:0 S %=$O(DXS(S,%)) Q:%=""  S ^DIPT(+Y,"DXS",S,%)=DXS(S,%)
 F S=1:1:DJ S ^DIPT(+Y,"F",S)=^UTILITY("DIP2",$J,S)
 I DE]"" S ^DIPT(+Y,"F",S+1)=DE
 I $G(DDXP)=2 S DDXPFDTM=+Y G Q^DIP
 I $D(DIAR) S DIARP=+Y
SUB I DHD="@" W !,"DO YOU ALWAYS WANT TO SUPPRESS SUBHEADERS WHEN PRINTING TEMPLATE" S %=1 D YN^DICN G DIP21^DIQQQ:'%,Q^DIP:%<0 I %=1 S ^DIPT(+Y,"SUB")=1,DISH=1
 I 'DA,$D(^DD("OS",DISYS,"ZS")) S X=DA,DMAX=^DD("ROU") D ENDIP^DIPZ I $D(^DIPT(DIPZ,"H")) S DHD=^("H")
OUT G PAGE^DIP3
 ;
W S %=$P(^(0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q
 Q
D ;
 S X=$P(X,"]"),X=$P(X,"[")_$P(X,"[",2),D="F"_DK S:'$D(^DIPT(D,"CAPTIONED",.01)) ^(.01)=1 I $D(^DIPT("B","WPDI",.001)),'$D(^DIPT(D,"WPDI",.001)) S ^(.001)=1
 K DIC S DIC="^DIPT("
 S DIC("S")="S %=^(0) I $P(%,U,8)'=2!($G(DIAR)=6),$P(%,U,8)'=3!($G(DDXP)=4),$P(%,U,8)'=7!($G(DDXP)=2),$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&(L!($D(DIASKHD))))
 Q
ACC(ND) ;set xcutable code to check FIELD access (in ND) against DUZ(0)
 N A
 S A="N % I 1 Q:'$D(^("_ND_"))  F %=1:1:$L(^("_ND_")) I DUZ(0)[$E(^("_ND_"),%) Q"
 Q A

DIP22
DIP22 ;SFISC/GFT-EDIT PRINT TEMPLATE ;12/16/92  09:12
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DC(1)=$O(^DIPT(DC(0),"F",DC(1))),DC=0 S:DC(1)="" DC(1)=-1 Q:DC(1)<0  S DC=2,DY=^(DC(1)),Y=2
Y S X=$P(DY,$C(126),1),DY=$P(DY,$C(126),2,99) I X="" G DIP22:'$D(DC(2)) Q
 I D9]"" G UP:$P(X,D9,1)]"" S X=$P(X,D9,2,99)
R I X'>0 G 0:$E(X,2)'=C&'X S:+X D9=D9_+X_C,DRK=-X G M
 I X[C S DA=$P(X,C,1) I +DA=DA S:DA<0 DA=-DA G Y:'$D(^DD(DRK,DA,0)) S X=$P(X,C,2,99),DC(Y)=$P(^(0),U,1),%=+X,D=+$P(^(0),U,2) G Y:'$D(^DD(D,.01,0)),W:$P(^(0),U,2)["W" S DRK=D,Y=Y+1,D9=D9_DA_C G R
 S %=+X,D=DRK_U_% D DCL
 G Y:'$D(^DD(DRK,%,0))
W S X=$P(^(0),U,1)_$E(X,$L(%)+1,999)
P S DC(Y)=X,Y=Y+1 G Y
0 S:X?1"0".E X=$S($D(^DD(DRK,.001,0)):$P(^(0),U,1),1:"NUMBER")_$E(X,2,999) S D=DRK_"^0" D DCL
M S %=$F(X,";Z;""") G P:'% S %=%-$L($P(X,";",1)),X=";"_$P(X,";",2,99) F D=%:0 S D=$F(X,Q,D) I ";"[$E(X,D) S X=$E(X,%,D-2)_$E(X,1,%-5)_$E(X,D,999) G P
 ;
UP S DRK=J(0),%=D9,DA=""
DOWN I X[C,+X=$P(X,C,1),$P(D9,DA_+X_C,1)="" S DA=DA_+X_C,%=$P(%,C,2,99),DRK=$S(X'>0:-X,1:+$P(^DD(DRK,+X,0),U,2)),X=$P(X,C,2,99) G DOWN
NUL S D9=DA,DC(Y)="",Y=Y+1,%=$P(%,C,2,99) G NUL:%]"",R
 ;
X ;
 S DC(1)=DD D Y F D=2:1 Q:'$D(DC(D))  S X=DC(D) X DICMX I '$D(D) K DD Q
 Q
 ;
HARD ;
 S DM=X,DQI="DIP(",DA="DXS("_DXS_C,S=S_";Z;"""_X_Q,DICOMP=DIL_$E("?",''L)_"TI"
 S DICOMPX=""
 I X'?.E1":" S DICMX="X DICMX" D EN^DICOMP G QQ:'$D(X)&'$D(FLDS) D FLY G S^DIP2
 S DICMX="S DIXX=DIXX("_DL_") D M" D ^DICOMPW
 I $D(X) S %=Y D OVFL,F S S=U_$P(DP,U,2)_U_$E(1,%["m")_U_S,X=1,P="",DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+DP,DV=DV_-DP_C,Y=0,DL=DL+1,DIL=+% K P G S^DIP2
QQ ;
 W $C(7),"??" G F^DIP2
 ;
FLY ;
 S:'$D(X) X=DM S %=Y["D"
 I %,S'[";R",S'[";L",$G(DDXP)'=2 S S=S_";L18"
 I Y["W",S'[";X" S S=S_";X"
 I Y["m" S:S'[";m" S=S_";m" I Y["w",S'[";w" S S=S_";w"
 D OVFL I P="",Y'["X" S X=X_$S(S[";W":"",%:" S Y=X D DT",1:" W X")_" K DIP"
F S S=X_S S:P]"" S=S_";"_P
DXS F Y=0:0 S Y=$O(X(Y)) S:Y="" Y=-1 Q:Y=-1  S @(DA_"Y)")=X(Y)
 S DXS=$D(X)>1+DXS K DATE,X Q
 ;
OVFL I $L(X)+$L(S)>180 S X(9)=X,X="X DXS("_DXS_",9)"
 Q
DIC I X="NUMBER" G B:'$D(DIAR),B:DIAR'=4,B:'$D(DC(DC)) S Y=X
 E  D ^DIC G E:'$D(DIAR),E:DIAR'=4,E:'$D(DC(DC)),RTN^DIP2:$E(X)="?"
 G E:'DC,E:$P(X,";")=$P(DC(DC),";"),E:$P($P(Y,U,2),";")=$P(DC(DC),";")
Z W !,$C(7),"Because this is an ARCHIVING process:"
 W !!,"You may ADD fields to output or CHANGE PREDEFINED FIELD formats"
 W !,"but NOT change, delete or do calculations on predefined fields.",!
 G 2^DIP2
E I $D(Y) G GF^DIP2:Y>0
 G UP^DIP2:X="",^DIP21:X?1"[".E&(DE="")
B S %=$L(X) F D="+","#","*","&","!" S Y=$S($E(X)=D:$E(X,2,999),$E(X,%)=D:$E(X,1,%-1),1:"") I Y]"" S P=D,X=Y G DIC
 I X[";" S S=";"_$P(X,";",2,99)_S,X=$P(X,";") G DIC
 I $E(X)="]" S X=$E(X,2,999),DALL(1)=1 G DIC
 G RTN^DIP2
 ;
DCL I $D(^DIPT(DC(0),"DCL",D)) S X=X_$E(^(D),$L(^(D)))
 Q

DIP23
DIP23 ;SFISC/XAK-PRINT TEMPLATE ;5/10/90  1:36 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
ED S DA=+Y,DRK=DK K Y
 S DRK=DK,DIE="^DIPT(",DR=".01;3;6" D ^DIE K DR G Q^DIP:$D(Y)
 S DC=0,DI=I(0) I $D(DA),'$D(^DIPT(DA,1)) S D9="",DC(0)=DA,DC(1)=-1 D ^DIP22 S DA=DC(0)
 I $D(DA),$D(^DIPT(DA,1)) D ^DIFGA G Q^DIP:$D(DTOUT),H^DIP3
 S DALL(1)=1 G ^DIP2

DIP3
DIP3 ;SFISC/GFT,TKW-PRINT HEADING, PAGE, COPIES ;9/2/94  11:01
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DJ,DE]"" S DJ=DJ+1,^UTILITY("DIP2",$J,DJ)=DE,DE=""
H G G:((L?1"]".E)!($G(DDXP)=2)!($G(DDXP)=4)) I '$D(DIASKHD),'L G:$D(DALL)>9 G G PAGE
 D HD
 S DA=X D HQ^DIP31 G Q^DIP:$D(DTOUT)!($D(DUOUT)) K DIRUT,DIROUT
 S DHD=X G:X=DA G
 I DHD?.P1"["1E.E F DC=1,2 S X=$P($P(DHD,"[",DC+1),"]",1) D D^DIP21 S DIC(0)="ESF",DIC("S")="I '$D(^(""DCL"")) "_DIC("S") D IX^DIC K DIC G H:Y<0&$L(X) I Y>0 S DHD=$P(DHD,"[",1,DC)_"["_$P(Y,U,2)_"]"_$P(DHD,"]",DC+1,9) W:L !
 I DHD?1"W ".E G G:DUZ(0)="@"!(DA=DHD) F %=1:2 G G:$P(DHD,Q,%,999)="" I $P($E(DHD,3,999),Q,%)[" " G H
 G H:DHD[Q
G S DHD=$G(DHD) G PUT^DIP21:$S(L?1"]".E:1,$D(DALL)>9:1,$D(DALL):0,1:$L(DE)>13!DJ),PAGE
X W $C(7),!,"TRY LATER" S X="^" G Q^DIP
 ;
PAGE ;
 K DICOMPX,DA,IO("C") S DISUPNO=$G(DISUPNO),DIPCRIT=$G(DIPCRIT),DC=$S($G(DDXP)'=4:",",1:"") S:$D(DOUT)#2 DA=DOUT I 'L,$D(PG) S DC=C_(PG-1) K PG
 E  I L,DHD'="@" F X=1:1:DPP I $D(DPP(X,"F")) R !,"START AT PAGE: 1// ",X:DTIME S:'$T X=U Q:X=""  G DIP3^DIQQQ:X["?",X:X[U,DIP3:X\1'=X S DC=C_(X-1) Q
 I $G(DIFIXPT)=1 G F2
 I $D(%ZIS)[0,$D(^%ZTSK),$D(^%ZTSCH("RUN")),$D(^%ZOSF("UCI")),$D(^DD("OS",DISYS,8)) S %ZIS="QM",%ZIS("B")=""
ZIS S:$D(IOP) DIOP=IOP D:$G(DDXP)=4 ZIS^DDXP4 D ^%ZIS S:$D(DIOP) IOP=DIOP K DIOP G X:POP
 I $G(DDXP)=4 S IOM=DDXPIOM,IOSL=$S(IOSL<DDXPIOSL:DDXPIOSL,1:IOSL),X=$S(IOM<255:IOM,1:0) X ^%ZOSF("RM")
 I $D(IOT),IOT="SDP",$D(^DD("OS",DISYS,"SDP")) G SDP
 G FREE
 ;
SDP S O=IO,DIPION=ION
 I '$D(DCOPIES) R !,"NUMBER OF COPIES: ",F:DTIME G SDPCLO:F[U!'$T,SDP:F\1'=F S DCOPIES=F
O K IOP,%ZIS S:$D(IO("Q")) %ZIS="NM",IOP="Q",%ZIS("B")="",DIOQ=1 W !,"OUTPUT COPIES TO"
 D ^%ZIS G SDPCLO:POP,O:IO=O
 S DOUT=$S($D(ION):ION_";"_IOM_";"_IOST,1:IO),DA=IO,IOP=DIPION_";"_IOM_";"_IOST S:$D(DIOQ) %ZIS="QN",IOP="Q;"_IOP K DIOQ D ^%ZIS
FREE S %=2,F=IOST["K",W=IOST["SINGLE"
 I $D(DIPZ),'$D(IOP),IO(0)=$I,$D(^DIPT(DIPZ,"IOM")),^("IOM")>IOM W $C(7),?8,"MARGIN WIDTH IS NORMALLY AT LEAST "_^("IOM"),!?8,"ARE YOU SURE" D YN^DICN G X:%<0,ZIS:%-1
 I IO(0)'=IO,'$D(IO("Q")),'$D(IOP)!$D(IOFREE),'W!F,IO(0)=$I,$S($D(DA):DA'=$I,1:1),$S($D(%ZIS)[0:1,1:%ZIS'["F"),$P(^DD("OS",DISYS,0),U,5) S %=2 W !,"WANT TO FREE UP THIS TERMINAL" D YN^DICN G CLO:%<0,DIP3^DIQQ:'% I %=1
 I $T!$D(IO("C")) W !,"THIS TERMINAL IS NOW FREE",!!,"Exit",! S IO("C")=1,X=$I,DM="" X ^DD("FUNC",7,1) K IO(1,IO) S:$D(DIOEND)#2 DIOEND(9)=DIOEND,DM="X DIOEND(9) " S DIOEND=DM_$S($D(^%ZIS("C")):"G H^XUS",1:"H")
F2 S X=$G(DHD) D HD:X="" S DHD=X,X=DC
 K DC,S,N,Q,H,DA,FR,TO,DM,J,T,V,CP,DIC,DIE,DRK,DINS,DALL S O=0,DK=DI,DC=X,C=","
 G ^DIP4:$D(IO("Q")) D CLEAN^DIEFU G ^DIP5
 ;
SDPCLO S X=O G CLO1
CLO S X=IO
CLO1 X ^DD("FUNC",7,1) K:$D(IO)#2&(IO]"") IO(1,IO) G X
 ;
HD S @("X=$P("_DI_"0),U)"),X=X_$S($D(DCL)>9:" STATISTICS",$D(DIAX):" EXTRACT SEARCH",$D(DIAR):" ARCHIVE SEARCH",$D(DIS)>9:" SEARCH",1:" LIST")
 I $D(DC(0)),$D(^DIPT(DC(0),"H")) S X=^("H")
 I $D(DIASKHD),$D(DHD)#2 S:DHD'["?" (DIASKHD,X)=DHD S:DIASKHD'="" (X,DHD)=DIASKHD
 Q

DIP31
DIP31 ;SFISC/TKW-ASK USER QUESTIONS ABOUT HEADING ;1/20/95  08:22
 ;;21.0;VA FileMan;**2**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
HQ N DISAVX,Y,DA,DIZ S DISAVX=X K DIR,DTOUT,DUOUT,DIRUT
 G:$D(DISUPNO)!($D(DIPCRIT)) HQ1 S DISUPNO=0,DIPCRIT=0
 W !!,"  *************************"
 I $D(DIS)>9 S DIZ(1)=$$EZBLD^DIALOG(8006),DIZ(2)=$$EZBLD^DIALOG(8038)
 E  S DIZ(1)=$$EZBLD^DIALOG(8007),DIZ(2)=$$EZBLD^DIALOG(8037)
 S DIR("A")=$$EZBLD^DIALOG(8008) D BLD^DIALOG(8005,.DIZ,"","DIR(""?"")")
 S DIR("B")=X,DIR(0)="FOU" D ^DIR K DIR G Q:$D(DIRUT)
 Q:X=""  I "SC"'[X,"CS"'[X Q
 W ! I X["S" S DISUPNO=1 D BLD^DIALOG(8010,.DIZ,"","DIR") W !,"  ",DIR
 I X["C" S DIPCRIT=1,DIZ=DIZ(2) D BLD^DIALOG(8011,DIZ,"","DIR") W !,"  ",DIR
 W !!
HQ1 D BLD^DIALOG(8009,"","","DIR(""?"")")
 S DIR("A")=$$EZBLD^DIALOG(8012),DIR("B")=DISAVX,DIR(0)="FOU^^K:X]""""&(""SC""[X!(""CS""[X)) X" D ^DIR K DIR G Q
 ;
Q S:$D(DUOUT)!($D(DTOUT)) X="^" Q
 ;DIALOG #8005  'There are two different options:'
 ;       #8006  'Number of Matches from the search'
 ;       #8007  'heading when there are no records to print'
 ;       #8008  'Heading/S/C'
 ;       #8009  'Accept default heading or enter a custom heading...'
 ;       #8010  '** Suppress the...'
 ;       #8011  '** Print...criteria in heading.'
 ;       #8012  'Heading'
 ;       #8037 'sort'
 ;       #8038  'search'

DIP4
DIP4 ;SFISC/XAK-QUEUE & DEQUEUE ;6/13/95  09:36
 ;;21.0;VA FileMan;**9**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S:('$D(DQTIME)#2)&($D(ZTQUEUED)) DQTIME="NOW"
 S:($G(DDXP)=4)&($D(IO("Q"))) DDXPQ=1 K IO("Q") S %DT="TEX",X="" I $D(DQTIME)#2 S X=DQTIME,%DT="XT"
W R:'$D(DQTIME) !,"REQUESTED TIME TO PRINT: NOW// ",X:DTIME
 G X^DIP3:X[U!'$T S Y=$H
 I $P("NOW",X)]"" S:X'["@" X="T@"_X S %DT(0)="NOW" D ^%DT K %DT(0) G:Y<1 X^DIP3:$D(DQTIME),W S X=+Y D H^%DTC S Y=%H_","_%T
 W:'$D(ZTQUEUED) ! S ZTDTH=Y X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ZTSK^DIP4",ZTDESC=DHD
 S ZTSAVE("^UTILITY(""DIP2"",$J,")=""
 I $P($G(DPP(0,"IX")),U,2)["$J" S ZTSAVE("^"_$P(DPP(0,"IX"),U,2))=""
 I $G(DPP(1,"IX"))["^UTILITY(" S ZTSAVE("^UTILITY(U,$J,")=""
 S ZTIO=$S($D(ION)#2:ION,1:IO) I $G(IOST)]"" S ZTIO=ZTIO_";"_IOST
 I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_IO("DOC") G ZTM
 I $G(IOM) S ZTIO=ZTIO_";"_IOM I $G(IOSL) S ZTIO=ZTIO_";"_IOSL
ZTM S ZTSAVE("*")="" D ^%ZTLOAD
 K ^UTILITY("DIP2",$J),^UTILITY(U,$J),DIS,DXS,DX,DHD,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTUCI,FLDS,DCC,DIPT,X
 W:'$D(ZTQUEUED) "REQUEST QUEUED!",!,"Task number: "_$G(ZTSK),! X $G(^%ZIS("C")) G Q^DIP
 ;
ZTSK ;
 K DISYS D CLEAN^DIEFU
 I $G(DPP(1))]"",'$D(DPP(1,"GET")) Q:$G(DK)=""  D 
 . S DIPCRIT=+$G(DIPCRIT),DISUPNO=$S($D(DISUPNO)#2:DISUPNO,1:1)
 . N S,Q S DIFM=+$G(L),S=+$P($G(@(DK_"0)")),U,2),Q="""" N DIBTRPT,DICNVDPP,DITYP,DJ,DU,DV
 . S DICNVDPP=1 D CNVCM^DIP11,T1^DIP11
 . Q
 D 0^DICRW G DQ^DITC1:$D(DIT),^DIP5

DIP5
DIP5 ;SFISC/GFT-INITIALIZE TO PROCESS THE PRINT ;4/11/96  08:01
 ;;21.0;VA FileMan;**2,21**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %H=$H D YMD^%DTC S DT=X K %H,^UTILITY($J),^("DIL",$J)
 I $G(DIFIXPT)=1 D  G GO
 . S ^UTILITY($J,1)="S DIFIXPTH="""_DHD_""",DC=1"
 . Q
 U IO
 S Z=IOM-33,DIOSL=IOSL,M=$P("I 1 S Y=1,DIFF=1 W:DC?.N $C(7) R:DC?.N Y:DTIME S:'$T Y=U S:Y=U (DN,S)=0 I Y'=U ",U,IOST?1"C".E)
 I M]"",DHD="@@" S M=M_"S IOX=$X,IOY=0 "_^DD("OS",DISYS,"XY")_" "
 S ^UTILITY($J,1)=M_"S DC=$P(DC,"","",2)+DC+1",M=DHD?1"W ".E
 I DHD'="@@" S ^UTILITY($J,1)=^(1)_" W:$D(DIFF)&($Y) "_IOF_$P(",#",U,IOF'["#"),A1="S DIFF=1,IOX=0,IOY=0 "_^DD("OS",DISYS,"XY") S:$L(^UTILITY($J,1))+$L(A1)>200 ^(1.3)=A1,A1="X ^(1.3)" S ^(1)=^(1)_" "_A1 K A1
 I W S ^(1)=^(1)_" W $C(7)"_$S(F:"",1:" U """_IO(0)_"""")_" R Y"_$S(F:"",1:" U IO")_" W """""
 I M S ^(1)=^(1)_" X ^(1.5)",^(1.5)=DHD G GO
 I DHD'?.P1"[".E1"]",DHD'?1"@".E D
 .N D,X,% S M=$P($H,C,2)\60,^UTILITY($J,2)=","_$E("!",$L(DHD)+2'<Z)_"?"_Z_" S Y="_(M#60/100+(M\60)/100+DT)_" D DT W ""    PAGE "",DC",D=3
 .I DIPCRIT S X="",%=0 D
 ..N A,B,S S (B,S)=1
 ..F  S %=$O(DISTXT(%)) D:'% AS Q:'%  S A=$G(DISTXT(%,0)) I A]"" S A=$$CONVQQ^DILIBF(A) D:$L(X)+$L(A)+20>IOM AS S X=X_$P(",  ^",U,(X]""))_A
 ..S S=1,B=2
 ..F  S %=$O(DPP(%)) D:%="" AS Q:%=""  S A=$G(DPP(%,"TXT")) I A]"" S A=$$CONVQQ^DILIBF(A) D:$L(X)+$L(A)+20>IOM AS S X=X_$P(",  ^",U,(X]""))_A
 ..I $G(DIPZ) F S=3:1:D S A=$G(^UTILITY($J,S)) I A]"",$D(^(S+1)) S ^(S)=A_" X ^UTILITY($J,"_(S+1)_")"
 ..I DIPCRIT=1,D>3 S:$G(DIPZ) ^(D-1)=^UTILITY($J,D-1)_" X ^UTILITY($J,"_D_")" S ^UTILITY($J,D)="S DIPCRIT=0",D=D+1
 ..Q
 .S %=$S($D(^UTILITY($J,3)):28,1:0),M="W """_DHD_"""" S:$L(M)+$L(^(2))+%>252 ^(2.5)=DHD,M="W ^(2.5)" S ^(2)=M_^(2)
 .I $G(DIPZ),%>0 S ^(2)=^(2)_" X"_$P(":DIPCRIT^",U,(DIPCRIT=1))_" ^UTILITY($J,3)"
 .S DHD=D Q
GO S X=0 F Y=$G(DPP(0))+1:1 Q:'$D(DPP(Y))  S X=X+1 D
 . Q:$D(DPP(Y,"SER"))#2
 . I X=1,'$O(DPP(Y)) Q:'$D(DPP(Y,"PTRIX"))  Q:$O(DPP(Y,0))
 . I $O(DPP(Y,0)) K:$D(DPP(Y,"PTRIX")) DPP(Y,"PTRIX"),DPP(Y,"IX") Q
 . I $D(DPP(Y,"CM")),'$D(DPP(Y,"PTRIX")) Q
 . N N,%,X,S S N=0,(%,X)="",S=$P(DPP(Y),U) Q:S<2
 . I $P(DPP(Y),U,2)=.01!($P(DPP(Y),U,2)=0) I '$D(DPP(Y,"F")),'$D(DPP(Y,"T")) S (%,X)=0 G CAL
 . D
 .. N I S I=Y N Y,DIBT1
 .. D SER^DIOQ(S,DPP(I,"GET"),DPP(I,"QCON"),$D(DPP(I,"IX"))#2,.X,.%,N)
 .. Q
CAL .I $D(DPP(Y,"PTRIX")) D
 .. N F,T,N S F=+$P($G(@(^DIC(+S,0,"GL")_"0)")),U,4)
 .. S T=$P($G(^DD(+S,+$P($P(DPP(Y),U,4),"""",2),0)),U,3) Q:T=""  S T=$P($G(@("^"_T_"0)")),U,4)
 .. S N=$S(Y>($G(DPP(0))+1):2,$O(DPP(Y)):2,1:1)
 .. I (T*(1-%)*N)>F S X=% K DPP(Y,"IX"),DPP(Y,"PTRIX")
 .. Q
 . Q:%=""  Q:X=""  S X=X_U_%,DPP(Y,"SER")=X
 . I $G(DIBT1) S %=Y-$G(DPP(0)) I $D(^DIBT(DIBT1,2,%)) S ^DIBT(DIBT1,2,%,"SER")=X
 . Q
 S X=0 F Y=1:1:DPP I $P(DPP(Y),U,4)["!" S X=1,DRK=1 Q
 G DIPZ:$D(DIPZ) D INIT S R=DE,DJ=-1 I X S (X,W)="",Y=",DRK",DRJ=0,DLN=3 K DNP D O^DIL
DIL D ^DIL:R]"" S DJ=$S(DIPT:+$O(^DIPT(DIPT,"F",DJ)),1:+$O(^UTILITY("DIP2",$J,DJ))) I DJ S R=^(DJ) G DIL
 D UNSTACK^DIL:DM,A^DIL G ^DIL2
 ;
AS S:X]"" ^UTILITY($J,D)="W"_$P(":DIPCRIT^",U,DIPCRIT)_" !,?"_$S(S=1:"0,"_""""_$P("Search^Sort",U,B)_" Criteria: ",1:"15,"_"""")_X_"""",D=D+1,S=S+1
 S X="" Q
 ;
INIT ;
 D:'$D(DISYS) OS^DII K DIL,DIWR S DN=-2,(DIL,DIL0,DIWL,DIO,DIO("SCR"),DM,DG,DX,DHT,DLN)=0,DY="D0",DI=DK_DY,@("DP=+$P("_DK_"0),U,2)"),M(DP)=1,DP(0)=DP,F="",Y=$S($D(^DD("OS"))[0!'$D(^DD("OS",DISYS,0)):0,1:$P(^(0),U,2)),DISMIN=99999
 Q
 ;
DIPZ I $S('$D(^DIPT(DIPZ,"ROU")):1,^("ROU")'[U:1,'$D(^("IOM")):1,1:^("IOM")>IOM)!X S Y=DIPZ D F^DIP21 K DIPZ G GO
 S Y=DIPZ D F^DIP21 S DK=DCC D INIT S ^UTILITY($J,99,1)="D "_^DIPT(DIPZ,"ROU"),DX=1
 S X="" F DG=0:0 S X=$O(^DIPT(DIPZ,"STATS",X)) Q:X=""  S %X="^DIPT(DIPZ,""STATS"",X,",%Y=X_"(" D %XY^%RCR
 F X=-1:0 S X=$O(^DIPT(DIPZ,"T",X)) Q:'X  S ^UTILITY($J,"T",X)=^(X)
 F X=-1:0 S X=$O(DPQ(X)) Q:X=""  F %=-1:0 S %=$O(DPQ(X,%)) Q:%=""  K:$D(^DIPT("AF",X,$S(%:%,1:.001),DIPZ)) DPQ(X,%)
 G ^DIL2

DIPKI001
DIPKI001 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(9.4,0,"GL")
 ;;=^DIC(9.4,
 ;;^DIC("B","PACKAGE",9.4)
 ;;=
 ;;^DIC(9.4,"%",0)
 ;;=^1.005^1^1
 ;;^DIC(9.4,"%",1,0)
 ;;=XU
 ;;^DIC(9.4,"%","B","XU",1)
 ;;=
 ;;^DIC(9.4,"%D",0)
 ;;=^^15^15^2940705^^^^
 ;;^DIC(9.4,"%D",1,0)
 ;;=This file identifies the elements of a package that will be transported
 ;;^DIC(9.4,"%D",2,0)
 ;;=by the initialization routines created by DIFROM.  The prefix determines
 ;;^DIC(9.4,"%D",3,0)
 ;;=which namespaced entries will be retrieved from the Option, Bulletin,
 ;;^DIC(9.4,"%D",4,0)
 ;;=Help Frame, Function, and Security Key Files as well as the namespace
 ;;^DIC(9.4,"%D",5,0)
 ;;=that will be used to name the INIT routines built by running DIFROM.
 ;;^DIC(9.4,"%D",6,0)
 ;;=The Excluded Namespace field may be used to leave out some of these items.
 ;;^DIC(9.4,"%D",7,0)
 ;;=The File Multiple determines which files are sent with the package and
 ;;^DIC(9.4,"%D",8,0)
 ;;=whether data is included.  Print, Input, Sort and Screen (FORM)
 ;;^DIC(9.4,"%D",9,0)
 ;;=templates are brought in by namespace, for the files listed in the File
 ;;^DIC(9.4,"%D",10,0)
 ;;=multiple.  In addition, there are multiples for each type of template,
 ;;^DIC(9.4,"%D",11,0)
 ;;=that allow the user to specify individual templates outside the
 ;;^DIC(9.4,"%D",12,0)
 ;;=namespace to retrieve.  Routines to be run before and after the
 ;;^DIC(9.4,"%D",13,0)
 ;;=INIT are specified in the Environment Check Routine, Pre-init after
 ;;^DIC(9.4,"%D",14,0)
 ;;=User Commit, and Post-Initialization Routine fields. The remaining
 ;;^DIC(9.4,"%D",15,0)
 ;;=fields are simply for documentation.
 ;;^DD(9.4,0)
 ;;=FIELD^NL^1946^40
 ;;^DD(9.4,0,"DDA")
 ;;=N
 ;;^DD(9.4,0,"DT")
 ;;=2940607
 ;;^DD(9.4,0,"ID",1)
 ;;=W:$D(^("0")) "   ",$P(^("0"),U,2)
 ;;^DD(9.4,0,"IX","AMRG",9.402,.01)
 ;;=
 ;;^DD(9.4,0,"IX","AR",9.44,.01)
 ;;=
 ;;^DD(9.4,0,"IX","B",9.4,.01)
 ;;=
 ;;^DD(9.4,0,"IX","C",9.4,1)
 ;;=
 ;;^DD(9.4,0,"IX","D",9.42,.01)
 ;;=
 ;;^DD(9.4,0,"NM","PACKAGE")
 ;;=
 ;;^DD(9.4,0,"PT",.84,1.2)
 ;;=
 ;;^DD(9.4,0,"PT",4.01,.01)
 ;;=
 ;;^DD(9.4,0,"PT",4.332,.01)
 ;;=
 ;;^DD(9.4,0,"PT",15.01101,.01)
 ;;=
 ;;^DD(9.4,0,"PT",19,12)
 ;;=
 ;;^DD(9.4,0,"PT",8989.332,.01)
 ;;=
 ;;^DD(9.4,.01,0)
 ;;=NAME^RF^^0;1^K:$L(X)>30!($L(X)<4)!'(X'?1P.E) X
 ;;^DD(9.4,.01,1,0)
 ;;=^.1
 ;;^DD(9.4,.01,1,1,0)
 ;;=9.4^B
 ;;^DD(9.4,.01,1,1,1)
 ;;=S ^DIC(9.4,"B",X,DA)=""
 ;;^DD(9.4,.01,1,1,2)
 ;;=K ^DIC(9.4,"B",X,DA)
 ;;^DD(9.4,.01,3)
 ;;=Please enter the name of this PACKAGE (4-30 characters).
 ;;^DD(9.4,.01,21,0)
 ;;=^^1^1^2940627^^^^
 ;;^DD(9.4,.01,21,1,0)
 ;;=The name of this Package.
 ;;^DD(9.4,1,0)
 ;;=PREFIX^RFX^^0;2^K:$L(X)>4!(X'?1U1.3NU) X I $D(X) S %=$O(^DIC(9.4,"C",X,0)) K:(%>0)&(%-DA) X
 ;;^DD(9.4,1,.1)
 ;;=NAMESPACE
 ;;^DD(9.4,1,1,0)
 ;;=^.1
 ;;^DD(9.4,1,1,1,0)
 ;;=9.4^C
 ;;^DD(9.4,1,1,1,1)
 ;;=S ^DIC(9.4,"C",X,DA)=""
 ;;^DD(9.4,1,1,1,2)
 ;;=K ^DIC(9.4,"C",X,DA)
 ;;^DD(9.4,1,3)
 ;;=Please enter the unique namespace prefix (2-4 characters, starting with an alpha).
 ;;^DD(9.4,1,21,0)
 ;;=^^4^4^2940627^^^^
 ;;^DD(9.4,1,21,1,0)
 ;;=This is the unique namespace prefix assigned to the Package, e.g. XM for
 ;;^DD(9.4,1,21,2,0)
 ;;=the MailMan routines and globals, DI for the FileMan routines, etc.
 ;;^DD(9.4,1,21,3,0)
 ;;=This field is appended to letters (like "INIT") to be used as the
 ;;^DD(9.4,1,21,4,0)
 ;;=names of INIT routines.
 ;;^DD(9.4,1,"DT")
 ;;=2890223
 ;;^DD(9.4,2,0)
 ;;=SHORT DESCRIPTION^RF^^0;3^K:$L(X)>60!($L(X)<2) X
 ;;^DD(9.4,2,3)
 ;;=Answer must be 2-60 characters in length.
 ;;^DD(9.4,2,21,0)
 ;;=1
 ;;^DD(9.4,2,21,1,0)
 ;;=This is a brief description of this Package's functions.
 ;;^DD(9.4,2,"DT")
 ;;=2890627
 ;;^DD(9.4,3,0)
 ;;=DESCRIPTION^9.41A^^1;0
 ;;^DD(9.4,3,21,0)
 ;;=^^2^2^2920513^^^
 ;;^DD(9.4,3,21,1,0)
 ;;=This is a complete and detailed description of the Package's functions
 ;;^DD(9.4,3,21,2,0)
 ;;=and capabilities.
 ;;^DD(9.4,4,0)
 ;;=*ROUTINE^9.42A^^2;0
 ;;^DD(9.4,4,21,0)
 ;;=^^3^3^2920513^^^^
 ;;^DD(9.4,4,21,1,0)
 ;;=These are the routines which make up this Package.  This multiple
 ;;^DD(9.4,4,21,2,0)
 ;;=is used for documentation only, and is not used during the INIT
 ;;^DD(9.4,4,21,3,0)
 ;;=process.
 ;;^DD(9.4,4,"DT")
 ;;=2940603
 ;;^DD(9.4,5,0)
 ;;=*GLOBAL^9.43^^3;0
 ;;^DD(9.4,5,21,0)
 ;;=^^2^2^2920513^^^^
 ;;^DD(9.4,5,21,1,0)
 ;;=These are the globals which make up this Package.  This multiple is used
 ;;^DD(9.4,5,21,2,0)
 ;;=for documentation purposes only.

DIPKI002
DIPKI002 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.4,5,"DT")
 ;;=2940603
 ;;^DD(9.4,6,0)
 ;;=*FILE^9.44PA^^4;0
 ;;^DD(9.4,6,21,0)
 ;;=^^3^3^2920513^^^^
 ;;^DD(9.4,6,21,1,0)
 ;;=Any FileMan files which are part of this Package are documented
 ;;^DD(9.4,6,21,2,0)
 ;;=here.  This multiple controls what files (Data Dictionaries and
 ;;^DD(9.4,6,21,3,0)
 ;;=Data) are sent in an INIT built from this Package entry.
 ;;^DD(9.4,6,"DT")
 ;;=2940603
 ;;^DD(9.4,7,0)
 ;;=*PRINT TEMPLATE^9.46^^DIPT;0
 ;;^DD(9.4,7,21,0)
 ;;=^^4^4^2921202^^^^
 ;;^DD(9.4,7,21,1,0)
 ;;=The names of Print Templates being sent with this Package.
 ;;^DD(9.4,7,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.4,7,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.4,7,21,4,0)
 ;;=separately.
 ;;^DD(9.4,7,"DT")
 ;;=2940603
 ;;^DD(9.4,8,0)
 ;;=*INPUT TEMPLATE^9.47^^DIE;0
 ;;^DD(9.4,8,21,0)
 ;;=^^4^4^2920513^^^
 ;;^DD(9.4,8,21,1,0)
 ;;=The names of the Input Templates being sent with this Package
 ;;^DD(9.4,8,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.4,8,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.4,8,21,4,0)
 ;;=separately.
 ;;^DD(9.4,8,"DT")
 ;;=2940603
 ;;^DD(9.4,9,0)
 ;;=*SORT TEMPLATE^9.48^^DIBT;0
 ;;^DD(9.4,9,21,0)
 ;;=^^4^4^2920513^^^
 ;;^DD(9.4,9,21,1,0)
 ;;=The names of the Sort Templates being sent with this Package.
 ;;^DD(9.4,9,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.4,9,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.4,9,21,4,0)
 ;;=separately.
 ;;^DD(9.4,9,"DT")
 ;;=2940603
 ;;^DD(9.4,9.1,0)
 ;;=*SCREEN TEMPLATE (FORM)^9.485^^DIST;0
 ;;^DD(9.4,9.1,21,0)
 ;;=^^2^2^2920513^^^
 ;;^DD(9.4,9.1,21,1,0)
 ;;=The names of Screen Templates (from the FORM file) associated with
 ;;^DD(9.4,9.1,21,2,0)
 ;;=this package.
 ;;^DD(9.4,9.1,"DT")
 ;;=2940603
 ;;^DD(9.4,9.5,0)
 ;;=*MENU^9.495^^M;0
 ;;^DD(9.4,9.5,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,9.5,21,1,0)
 ;;=This is the name of a menu-type option in another namespace.
 ;;^DD(9.4,9.5,"DT")
 ;;=2940603
 ;;^DD(9.4,10,0)
 ;;=DEVELOPER (PERSON/SITE)^F^^DEV;1^K:$L(X)>50!($L(X)<2) X
 ;;^DD(9.4,10,3)
 ;;=Please enter the name of the principal Developer and Site (2-50 characters).
 ;;^DD(9.4,10,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.4,10,21,1,0)
 ;;=The name of the principal Developer and Site for this Package.
 ;;^DD(9.4,10.6,0)
 ;;=*LOWEST FILE NUMBER^NJ12,2^^11;1^K:+X'=X!(X>999999999)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(9.4,10.6,3)
 ;;=Type a Number between 0 and 999999999, 2 Decimal Digits
 ;;^DD(9.4,10.6,21,0)
 ;;=^^1^1^2920513^^^^
 ;;^DD(9.4,10.6,21,1,0)
 ;;=Inclusive lower bound of the range of file numbers allocated to this package.
 ;;^DD(9.4,10.6,"DT")
 ;;=2940603
 ;;^DD(9.4,11,0)
 ;;=*HIGHEST FILE NUMBER^NJ12,2^^11;2^K:+X'=X!(X>999999999)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(9.4,11,3)
 ;;=Type a Number between 0 and 999999999, 2 Decimal Digits
 ;;^DD(9.4,11,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,11,21,1,0)
 ;;=Inclusive upper bound of the range of file numbers assigned to this package.
 ;;^DD(9.4,11,"DT")
 ;;=2940603
 ;;^DD(9.4,11.01,0)
 ;;=DEVELOPMENT ISC^F^^5;1^K:$L(X)>20!($L(X)<3) X
 ;;^DD(9.4,11.01,3)
 ;;=Please enter the name of the ISC (3-20 characters).
 ;;^DD(9.4,11.01,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,11.01,21,1,0)
 ;;=The ISC responsible for the development and management of this Package.
 ;;^DD(9.4,11.01,"DT")
 ;;=2840815
 ;;^DD(9.4,11.1,0)
 ;;=*MAINTENANCE ISC^F^^7;1^K:$L(X)>20!($L(X)<3) X
 ;;^DD(9.4,11.1,3)
 ;;=Please enter the name of the ISC (3-20 characters).
 ;;^DD(9.4,11.1,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,11.1,21,1,0)
 ;;=The ISC responsible for the support and maintenance of this Package.
 ;;^DD(9.4,11.1,"DT")
 ;;=2940603
 ;;^DD(9.4,11.3,0)
 ;;=CLASS^S^I:National;II:Inactive;III:Local;^7;3^Q
 ;;^DD(9.4,11.3,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.4,11.3,21,1,0)
 ;;=The ranking Class of this software Package.
 ;;^DD(9.4,11.3,"DT")
 ;;=2940325
 ;;^DD(9.4,11.4,0)
 ;;=*VERIFICATION^9.404ID^^8;0
 ;;^DD(9.4,11.4,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,11.4,21,1,0)
 ;;=Information about the verification(s) of this Package.
 ;;^DD(9.4,11.4,"DT")
 ;;=2940603
 ;;^DD(9.4,11.5,0)
 ;;=*ALPHA^P4'^DIC(4,^9;1^Q
 ;;^DD(9.4,11.5,3)
 ;;=Please enter the name of the Alpha Test site.
 ;;^DD(9.4,11.5,21,0)
 ;;=^^1^1^2920513^^^

DIPKI003
DIPKI003 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.4,11.5,21,1,0)
 ;;=The name of this Package's Alpha Test site.
 ;;^DD(9.4,11.5,"DT")
 ;;=2940603
 ;;^DD(9.4,11.6,0)
 ;;=*BETA^P4'^DIC(4,^9;2^Q
 ;;^DD(9.4,11.6,3)
 ;;=Please enter the name of the Beta Test site.
 ;;^DD(9.4,11.6,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.4,11.6,21,1,0)
 ;;=The name of this Package's Beta Test site.
 ;;^DD(9.4,11.6,"DT")
 ;;=2940603
 ;;^DD(9.4,11.7,0)
 ;;=*DELTA^9.409P^^10;0
 ;;^DD(9.4,11.7,21,0)
 ;;=^^1^1^2920706^^
 ;;^DD(9.4,11.7,21,1,0)
 ;;=The names of the Delta Test sites for this Package.
 ;;^DD(9.4,11.7,"DT")
 ;;=2940603
 ;;^DD(9.4,12,0)
 ;;=*PRIMARY HELP FRAME^P9.2'^DIC(9.2,^0;4^Q
 ;;^DD(9.4,12,3)
 ;;=
 ;;^DD(9.4,12,21,0)
 ;;=^^1^1^2920416^^^
 ;;^DD(9.4,12,21,1,0)
 ;;=This is the primary Help Frame for this Package.
 ;;^DD(9.4,12,"DT")
 ;;=2940603
 ;;^DD(9.4,13,0)
 ;;=CURRENT VERSION^F^^VERSION;1^K:$L(X)>8!($L(X)<1)!'(X?1N.ANP) X
 ;;^DD(9.4,13,3)
 ;;=Enter the version of this package currently running, (1-8 characters).
 ;;^DD(9.4,13,21,0)
 ;;=^^5^5^2920702^
 ;;^DD(9.4,13,21,1,0)
 ;;=This field holds the version number of the package currently running
 ;;^DD(9.4,13,21,2,0)
 ;;=at this site.  When a package initialization has been run, this field
 ;;^DD(9.4,13,21,3,0)
 ;;=will be updated with the version number most recently installed.
 ;;^DD(9.4,13,21,4,0)
 ;;=This can be either using the old format (1.0, 16.04, etc.) or the new
 ;;^DD(9.4,13,21,5,0)
 ;;=format (18.0T4, 19.1V2, etc.)
 ;;^DD(9.4,13,"DT")
 ;;=2860221
 ;;^DD(9.4,20,0)
 ;;=AFFECTS RECORD MERGE^9.402P^^20;0
 ;;^DD(9.4,20,21,0)
 ;;=^^2^2^2940627^
 ;;^DD(9.4,20,21,1,0)
 ;;=This Multipule lists the files that will impact this package if a Record
 ;;^DD(9.4,20,21,2,0)
 ;;=Merge is done on any of the files in the list.
 ;;^DD(9.4,22,0)
 ;;=VERSION^9.49I^^22;0
 ;;^DD(9.4,22,21,0)
 ;;=^^1^1^2930415^^^^
 ;;^DD(9.4,22,21,1,0)
 ;;=The version numbers of this Package.
 ;;^DD(9.4,200.1,0)
 ;;=*USER TERMINATE TAG^F^^200;1^K:$L(X)>8!($L(X)<1)!'((X?1U.UN)!(X?1N.N)) X
 ;;^DD(9.4,200.1,3)
 ;;=Enter the entry TAG for the routine in field 200.2
 ;;^DD(9.4,200.1,21,0)
 ;;=^^3^3^2920306^^^
 ;;^DD(9.4,200.1,21,1,0)
 ;;=This field holds the entry point into the routine that will be called at
 ;;^DD(9.4,200.1,21,2,0)
 ;;=the time that a USER (File 200 entry with access/verify codes) is
 ;;^DD(9.4,200.1,21,3,0)
 ;;=terminated. See field 200.2
 ;;^DD(9.4,200.1,"DT")
 ;;=2940603
 ;;^DD(9.4,200.2,0)
 ;;=*USER TERMINATE ROUTINE^F^^200;2^K:$L(X)>8!($L(X)<2)!'(X?2U.UN) X
 ;;^DD(9.4,200.2,3)
 ;;=Enter a 2-8 character routine name.
 ;;^DD(9.4,200.2,21,0)
 ;;=^^7^7^2920306^^^
 ;;^DD(9.4,200.2,21,1,0)
 ;;=This field holds the name of a routine that will be called at the time
 ;;^DD(9.4,200.2,21,2,0)
 ;;=that a USER (File 200 entry with access/verify codes) is terminated.
 ;;^DD(9.4,200.2,21,3,0)
 ;;=ie. has their access/verify codes removed.
 ;;^DD(9.4,200.2,21,4,0)
 ;;=This is to allow each package to do their own clean-up.
 ;;^DD(9.4,200.2,21,5,0)
 ;;= 
 ;;^DD(9.4,200.2,21,6,0)
 ;;=At the time the call is made DA will hold the IFN of the user being
 ;;^DD(9.4,200.2,21,7,0)
 ;;=terminated. This normally runs in the background without an IO device.
 ;;^DD(9.4,200.2,"DT")
 ;;=2940603
 ;;^DD(9.4,913,0)
 ;;=*ENVIRONMENT CHECK ROUTINE^F^^PRE;1^K:$L(X)>8!($L(X)<3) X
 ;;^DD(9.4,913,.1)
 ;;=DEVELOPERS ROUTINE RUN BEFORE 'INIT' QUESTIONS ASKED
 ;;^DD(9.4,913,3)
 ;;=Enter name of developer's environment check routine (3-8 characters) that runs before any user questions are asked.  This routine should be used for environment check only and should not alter data.
 ;;^DD(9.4,913,21,0)
 ;;=^^4^4^2921202^
 ;;^DD(9.4,913,21,1,0)
 ;;=The name of the developer's routine which is run at the beginning of
 ;;^DD(9.4,913,21,2,0)
 ;;=the NAMESPACE_INIT routine.  This should just check the environment
 ;;^DD(9.4,913,21,3,0)
 ;;=and should not alter any data, since the user has no way to exit out of
 ;;^DD(9.4,913,21,4,0)
 ;;=the INIT process until this program runs to completion.
 ;;^DD(9.4,913,23,0)
 ;;=^^2^2^2921202^^^^
 ;;^DD(9.4,913,23,1,0)
 ;;=  A call to this routine gets inserted, by DIFROM at the beginning of the
 ;;^DD(9.4,913,23,2,0)
 ;;=NAMESPACE_INIT routine, before the EN entry point.
 ;;^DD(9.4,913,"DT")
 ;;=2940606
 ;;^DD(9.4,913.5,0)
 ;;=*ENVIRONMENT CHECK DONE DATE^D^^PRE;2^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.4,913.5,3)
 ;;=

DIPKI004
DIPKI004 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.4,913.5,21,0)
 ;;=^^3^3^2921202^
 ;;^DD(9.4,913.5,21,1,0)
 ;;=This is the date/time that the ENVIRONMENT CHECK routine last ran. When an
 ;;^DD(9.4,913.5,21,2,0)
 ;;=INIT is run at a target site, and it contains an ENVIRONMENT CHECK
 ;;^DD(9.4,913.5,21,3,0)
 ;;=routine, this field is updated automatically.
 ;;^DD(9.4,913.5,"DT")
 ;;=2940603
 ;;^DD(9.4,914,0)
 ;;=*POST-INITIALIZATION ROUTINE^F^^INIT;1^K:$L(X)>8!($L(X)<3)!'(X?1UP.UN) X
 ;;^DD(9.4,914,.1)
 ;;=DEVELOPERS ROUTINE TO BRANCH TO AT END OF 'INIT' ROUTINE
 ;;^DD(9.4,914,3)
 ;;=Enter the name of the developer's post-initialization routine (3-8 characters).
 ;;^DD(9.4,914,21,0)
 ;;=^^2^2^2900730^^^^
 ;;^DD(9.4,914,21,1,0)
 ;;=The name of the developer's routine which is run immediately after the
 ;;^DD(9.4,914,21,2,0)
 ;;=installation of the package.
 ;;^DD(9.4,914,23,0)
 ;;=^^3^3^2900730^^^
 ;;^DD(9.4,914,23,1,0)
 ;;=  This routine gets inserted by DIFROM at the end of the
 ;;^DD(9.4,914,23,2,0)
 ;;=NAMESPACE_INIT routine, after the INIT has filed all the information,
 ;;^DD(9.4,914,23,3,0)
 ;;=but before the quit statement.
 ;;^DD(9.4,914,"DT")
 ;;=2940606
 ;;^DD(9.4,914.5,0)
 ;;=*POST-INIT COMPLETION DATE^D^^INIT;2^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.4,914.5,3)
 ;;=
 ;;^DD(9.4,914.5,21,0)
 ;;=^^3^3^2911209^^
 ;;^DD(9.4,914.5,21,1,0)
 ;;=This is the date/time that the POST-INIT last ran.  When an
 ;;^DD(9.4,914.5,21,2,0)
 ;;=INIT is run at a target site, and it contains a POST-INIT
 ;;^DD(9.4,914.5,21,3,0)
 ;;=routine, this field is updated automatically.
 ;;^DD(9.4,914.5,"DT")
 ;;=2940603
 ;;^DD(9.4,916,0)
 ;;=*PRE-INIT AFTER USER COMMIT^F^^INI;1^K:$L(X)>8!($L(X)<3) X
 ;;^DD(9.4,916,.1)
 ;;=DEVELOPERS ROUTINE RUN AFTER 'INIT' QUESTIONS ANSWERED
 ;;^DD(9.4,916,3)
 ;;=Enter name of developer's pre-init routine (3-8 characters) that runs after user has answered all INIT questions.  Can be used for data conversions needed before INIT files new data.
 ;;^DD(9.4,916,21,0)
 ;;=^^4^4^2930303^^^^
 ;;^DD(9.4,916,21,1,0)
 ;;=Name of the developer's routine that runs after the user has answered all
 ;;^DD(9.4,916,21,2,0)
 ;;=of the questions in NAMESPACE_INIT but before the INIT files any new data.
 ;;^DD(9.4,916,21,3,0)
 ;;=Used for data conversions, etc. that the developer needs to do before
 ;;^DD(9.4,916,21,4,0)
 ;;=bringing in new data.
 ;;^DD(9.4,916,23,0)
 ;;=^^3^3^2930303^^^^
 ;;^DD(9.4,916,23,1,0)
 ;;=  A call to this routine gets inserted, by DIFROM, into the
 ;;^DD(9.4,916,23,2,0)
 ;;=NAMESPACE_INIT1 routine, after the user has answered the last
 ;;^DD(9.4,916,23,3,0)
 ;;=question 'ARE YOU SURE EVERYTHING'S OK?', but before filing any data.
 ;;^DD(9.4,916,"DT")
 ;;=2940606
 ;;^DD(9.4,916.5,0)
 ;;=*PRE-INIT COMPLETION DATE^D^^INI;2^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.4,916.5,21,0)
 ;;=^^3^3^2911209^^
 ;;^DD(9.4,916.5,21,1,0)
 ;;=This is the date/time that the PRE-INIT AFTER USER COMMIT last ran.
 ;;^DD(9.4,916.5,21,2,0)
 ;;=When an INIT is run at a target site, and it contains a PRE-INIT
 ;;^DD(9.4,916.5,21,3,0)
 ;;=AFTER USER COMMIT routine, this field is updated automatically.
 ;;^DD(9.4,916.5,"DT")
 ;;=2940603
 ;;^DD(9.4,919,0)
 ;;=*EXCLUDED NAME SPACE^9.432^^EX;0
 ;;^DD(9.4,919,21,0)
 ;;=^^5^5^2930303^^^
 ;;^DD(9.4,919,21,1,0)
 ;;=By specifying an "excluded name space", the developer will be telling
 ;;^DD(9.4,919,21,2,0)
 ;;=the DIFROM routine not to take OPTIONS, BULLETINS, etc. which begin
 ;;^DD(9.4,919,21,3,0)
 ;;=with these characters.  For example, if "PSZ" is an excluded name space
 ;;^DD(9.4,919,21,4,0)
 ;;=in the "PS" package, DIFROM will not send along OPTIONS, SECURITY KEYS,
 ;;^DD(9.4,919,21,5,0)
 ;;=BULLETINS, or FUNCTIONS that begin with "PSZ".
 ;;^DD(9.4,919,"DT")
 ;;=2940603
 ;;^DD(9.4,1920,0)
 ;;=*STATUS^9.444D^^ST;0
 ;;^DD(9.4,1920,21,0)
 ;;=^^1^1^2851008^^^
 ;;^DD(9.4,1920,21,1,0)
 ;;=Information about the Namespace assignment status of this package.
 ;;^DD(9.4,1920,"DT")
 ;;=2940606
 ;;^DD(9.4,1933,0)
 ;;=*KEY VARIABLE^9.455^^1933;0
 ;;^DD(9.4,1933,21,0)
 ;;=^^2^2^2851009^^^
 ;;^DD(9.4,1933,21,1,0)
 ;;=These are the MUMPS variables which the Package would like defined
 ;;^DD(9.4,1933,21,2,0)
 ;;=prior to entry into the routines.
 ;;^DD(9.4,1933,"DT")
 ;;=2940603
 ;;^DD(9.4,1944,0)
 ;;=*BULLETINS^XCmJ30^^ ; ^S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 S D=$O(^XMB(3.6,"B",X,0)) S:D="" D=-1 X:$D(^XMB(3.6,D,0)) DICMX S X=$O(^XMB(3.6,"B",X)) I $P(X,XU,1)]""!(X="") S X="" Q

DIPKI005
DIPKI005 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.4,1944,9)
 ;;=^
 ;;^DD(9.4,1944,9.01)
 ;;=
 ;;^DD(9.4,1944,9.1)
 ;;=S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 Q:$P(X,XU,1)]""!(X="")  S D=$O(^XMB(3.6,X,0)) S:D="" D=-1 X:$D(^XMB(3.6,D,0)) DICMX S X=$O(^XMB(3.6,"B",X))
 ;;^DD(9.4,1944,21,0)
 ;;=^^2^2^2851008^
 ;;^DD(9.4,1944,21,1,0)
 ;;=This presents information about any BULLETINs which are distributed
 ;;^DD(9.4,1944,21,2,0)
 ;;=along with the Package.
 ;;^DD(9.4,1944,"DT")
 ;;=2940606
 ;;^DD(9.4,1945,0)
 ;;=*SECURITY KEYS^XCmJ30^^ ; ^S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 X:$D(^XUSEC(X)) DICMX S X=$O(^XUSEC(X)) I $P(X,XU,1)]""!(X="") S X="" Q
 ;;^DD(9.4,1945,9)
 ;;=^
 ;;^DD(9.4,1945,9.01)
 ;;=
 ;;^DD(9.4,1945,9.1)
 ;;=S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 X:$D(^XUSEC(X)) DICMX S X=$O(^XUSEC(X)) I $P(X,XU,1)]""!(X="") S X="" Q
 ;;^DD(9.4,1945,21,0)
 ;;=^^2^2^2851008^
 ;;^DD(9.4,1945,21,1,0)
 ;;=This describes the SECURITY KEYs which are distributed along with
 ;;^DD(9.4,1945,21,2,0)
 ;;=the Package.
 ;;^DD(9.4,1945,"DT")
 ;;=2940606
 ;;^DD(9.4,1946,0)
 ;;=*OPTIONS^XCmJ30^^ ; ^S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 S D=$O(^DIC(19,"B",X,0)) S:D="" D=-1 X:$D(^DIC(19,D,0)) DICMX S X=$O(^DIC(19,"B",X)) I $P(X,XU,1)]""!(X="") S X="" Q
 ;;^DD(9.4,1946,9)
 ;;=^
 ;;^DD(9.4,1946,9.01)
 ;;=
 ;;^DD(9.4,1946,9.1)
 ;;=S (XU,X)=$P(^DIC(9.4,D0,0),U,2) I X?1A.E F D=0:0 Q:$P(X,XU,1)]""!(X="")  S D=$O(^DIC(19,"B",X,0)) S:D="" D=-1 X:$D(^DIC(19,D,0)) DICMX S X=$O(^DIC(19,"B",X))
 ;;^DD(9.4,1946,21,0)
 ;;=^^2^2^2851008^
 ;;^DD(9.4,1946,21,1,0)
 ;;=This lists information concerning the OPTIONs which are distributed
 ;;^DD(9.4,1946,21,2,0)
 ;;=along with the Package.
 ;;^DD(9.4,1946,"DT")
 ;;=2940606
 ;;^DD(9.402,0)
 ;;=AFFECTS RECORD MERGE SUB-FIELD^^4^3
 ;;^DD(9.402,0,"DT")
 ;;=2900906
 ;;^DD(9.402,0,"IX","B",9.402,.01)
 ;;=
 ;;^DD(9.402,0,"NM","AFFECTS RECORD MERGE")
 ;;=
 ;;^DD(9.402,0,"UP")
 ;;=9.4
 ;;^DD(9.402,.01,0)
 ;;=FILE AFFECTED^*P1'X^DIC(^0;1^S DIC("S")="I $D(^DD(15,.01,""V"",""B"",Y))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X S:$D(X) DINUM=X
 ;;^DD(9.402,.01,1,0)
 ;;=^.1
 ;;^DD(9.402,.01,1,1,0)
 ;;=9.402^B
 ;;^DD(9.402,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),20,"B",$E(X,1,30),DA)=""
 ;;^DD(9.402,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),20,"B",$E(X,1,30),DA)
 ;;^DD(9.402,.01,1,2,0)
 ;;=9.4^AMRG
 ;;^DD(9.402,.01,1,2,1)
 ;;=S ^DIC(9.4,"AMRG",$E(X,1,30),DA(1),DA)=""
 ;;^DD(9.402,.01,1,2,2)
 ;;=K ^DIC(9.4,"AMRG",$E(X,1,30),DA(1),DA)
 ;;^DD(9.402,.01,1,2,"%D",0)
 ;;=^^2^2^2900906^
 ;;^DD(9.402,.01,1,2,"%D",1,0)
 ;;=This xref is used by the merge process to determine if any package
 ;;^DD(9.402,.01,1,2,"%D",2,0)
 ;;=file entry affects the file being merged.
 ;;^DD(9.402,.01,1,2,"DT")
 ;;=2900906
 ;;^DD(9.402,.01,3)
 ;;=Pointer to a file that has been added to FILE 15's variable pointer.
 ;;^DD(9.402,.01,12)
 ;;=MUST BE VARIABLE POINTER FILE IN FIELD .01 OF FILE 15
 ;;^DD(9.402,.01,12.1)
 ;;=S DIC("S")="I $D(^DD(15,.01,""V"",""B"",Y))"
 ;;^DD(9.402,.01,21,0)
 ;;=^^1^1^2940627^^
 ;;^DD(9.402,.01,21,1,0)
 ;;=A file that if merged will affect this package.
 ;;^DD(9.402,.01,"DT")
 ;;=2900910
 ;;^DD(9.402,3,0)
 ;;=NAME OF MERGE ROUTINE^F^^0;3^K:$L(X)>8!($L(X)<2)!'(X?1U1.7UN) X
 ;;^DD(9.402,3,3)
 ;;=Answer with a routine name (1U.1.7UN).
 ;;^DD(9.402,3,21,0)
 ;;=^^4^4^2930330^
 ;;^DD(9.402,3,21,1,0)
 ;;=This field holds the routine name to call when two records in
 ;;^DD(9.402,3,21,2,0)
 ;;=an affected file are to be merged. This allows the package to
 ;;^DD(9.402,3,21,3,0)
 ;;=do any repointing or other clean-up needed before the records
 ;;^DD(9.402,3,21,4,0)
 ;;=are merged.
 ;;^DD(9.402,3,"DT")
 ;;=2900816
 ;;^DD(9.402,4,0)
 ;;=RECORD HAS PACKAGE DATA^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
 ;;^DD(9.402,4,3)
 ;;=This is Standard MUMPS code. To tell if this record has data in this package.
 ;;^DD(9.402,4,9)
 ;;=@
 ;;^DD(9.402,4,"DT")
 ;;=2900816
 ;;^DD(9.404,0)
 ;;=*VERIFICATION SUB-FIELD^NL^3^4
 ;;^DD(9.404,0,"ID",1)
 ;;=W:$D(^(0)) "   ",$P(^(0),U,2)
 ;;^DD(9.404,0,"NM","*VERIFICATION")
 ;;=
 ;;^DD(9.404,0,"UP")
 ;;=9.4
 ;;^DD(9.404,.01,0)
 ;;=VERIFICATION^DX^^0;1^S %DT="E" D ^%DT S (DINUM,X)=Y K:Y<1 DINUM,X
 ;;^DD(9.404,.01,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.404,.01,21,1,0)
 ;;=Date of notification that this software has been verified.
 ;;^DD(9.404,.01,"DT")
 ;;=2840815
 ;;^DD(9.404,1,0)
 ;;=ISC^F^^0;2^K:$L(X)>20!($L(X)<2) X
 ;;^DD(9.404,1,3)
 ;;=The name of the ISC responsible for verification (3-20 characters).

DIPKI006
DIPKI006 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.404,1,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.404,1,21,1,0)
 ;;=The name of the ISC where this verification was done.
 ;;^DD(9.404,1,"DT")
 ;;=2840815
 ;;^DD(9.404,2,0)
 ;;=VERSION^NJ6,2^^0;3^K:+X'=X!(X>999)!(X<0)!(X?.E1"."3N.N) X
 ;;^DD(9.404,2,3)
 ;;=Please enter the version number of this verified Package (0.00-999.99).
 ;;^DD(9.404,2,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.404,2,21,1,0)
 ;;=The version number of this verified Package.
 ;;^DD(9.404,2,"DT")
 ;;=2840815
 ;;^DD(9.404,3,0)
 ;;=COMMENTS^9.414^^1;0
 ;;^DD(9.404,3,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.404,3,21,1,0)
 ;;=Comments regarding this verified version of the Package.
 ;;^DD(9.409,0)
 ;;=*DELTA SUB-FIELD^NL^.01^1
 ;;^DD(9.409,0,"NM","*DELTA")
 ;;=
 ;;^DD(9.409,0,"UP")
 ;;=9.4
 ;;^DD(9.409,.01,0)
 ;;=DELTA^MP4'X^DIC(4,^0;1^S:$D(X) DINUM=X
 ;;^DD(9.409,.01,3)
 ;;=Please enter the name of the Delta Test site.
 ;;^DD(9.409,.01,21,0)
 ;;=^^1^1^2851007^
 ;;^DD(9.409,.01,21,1,0)
 ;;=The name of a Delta Test site for this Package.
 ;;^DD(9.409,.01,"DT")
 ;;=2840815
 ;;^DD(9.41,0)
 ;;=DESCRIPTION SUB-FIELD^NL^.01^1
 ;;^DD(9.41,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(9.41,0,"UP")
 ;;=9.4
 ;;^DD(9.41,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(9.41,.01,3)
 ;;=Please enter a complete and detailed description of the Package.
 ;;^DD(9.41,.01,21,0)
 ;;=^^2^2^2920513^^^^
 ;;^DD(9.41,.01,21,1,0)
 ;;=This is a complete and detailed description of the Package's functions
 ;;^DD(9.41,.01,21,2,0)
 ;;=and capabilities.
 ;;^DD(9.41,.01,"DT")
 ;;=2851007
 ;;^DD(9.414,0)
 ;;=COMMENTS SUB-FIELD^NL^.01^1
 ;;^DD(9.414,0,"NM","COMMENTS")
 ;;=
 ;;^DD(9.414,0,"UP")
 ;;=9.404
 ;;^DD(9.414,.01,0)
 ;;=COMMENTS^W^^0;1^Q
 ;;^DD(9.414,.01,3)
 ;;=Comments relating to verification
 ;;^DD(9.414,.01,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.414,.01,21,1,0)
 ;;=Comments regarding this verified version of the Package.
 ;;^DD(9.414,.01,"DT")
 ;;=2840815
 ;;^DD(9.42,0)
 ;;=*ROUTINE SUB-FIELD^NL^.01^1
 ;;^DD(9.42,0,"IX","B",9.42,.01)
 ;;=
 ;;^DD(9.42,0,"NM","*ROUTINE")
 ;;=
 ;;^DD(9.42,0,"UP")
 ;;=9.4
 ;;^DD(9.42,.01,0)
 ;;=ROUTINE^MFX^^0;1^K:$L(X)>8!($L(X)<1)!'(X?.UN!(X?1"%".UN)) X
 ;;^DD(9.42,.01,1,0)
 ;;=^.1^^-1
 ;;^DD(9.42,.01,1,1,0)
 ;;=9.4^D
 ;;^DD(9.42,.01,1,1,1)
 ;;=S ^DIC(9.4,"D",X,DA(1))=""
 ;;^DD(9.42,.01,1,1,2)
 ;;=K ^DIC(9.4,"D",X,DA(1))
 ;;^DD(9.42,.01,1,2,0)
 ;;=9.42^B
 ;;^DD(9.42,.01,1,2,1)
 ;;=S ^DIC(9.4,DA(1),2,"B",X,DA)=""
 ;;^DD(9.42,.01,1,2,2)
 ;;=K ^DIC(9.4,DA(1),2,"B",X,DA)
 ;;^DD(9.42,.01,3)
 ;;=Please enter a routine name (1-8 characters).
 ;;^DD(9.42,.01,21,0)
 ;;=^^3^3^2920513^^^^
 ;;^DD(9.42,.01,21,1,0)
 ;;=This multiple is used for documentation purposes only and does
 ;;^DD(9.42,.01,21,2,0)
 ;;=not control anything during the INIT process.  It is used to document
 ;;^DD(9.42,.01,21,3,0)
 ;;=the routines that are included in this Package.
 ;;^DD(9.42,.01,22)
 ;;=
 ;;^DD(9.42,.01,"DT")
 ;;=2850211
 ;;^DD(9.43,0)
 ;;=*GLOBAL SUB-FIELD^NL^5^3
 ;;^DD(9.43,0,"DT")
 ;;=2910827
 ;;^DD(9.43,0,"IX","B",9.43,.01)
 ;;=
 ;;^DD(9.43,0,"NM","*GLOBAL")
 ;;=
 ;;^DD(9.43,0,"UP")
 ;;=9.4
 ;;^DD(9.43,.01,0)
 ;;=GLOBAL^MF^^0;1^K:X[""""!(X'?.ANP)!(X<0) X I $D(X) K:$L(X)>15!($L(X)<1) X
 ;;^DD(9.43,.01,1,0)
 ;;=^.1
 ;;^DD(9.43,.01,1,1,0)
 ;;=9.43^B
 ;;^DD(9.43,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),3,"B",X,DA)=""
 ;;^DD(9.43,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),3,"B",X,DA)
 ;;^DD(9.43,.01,3)
 ;;=Enter name of global used in this package.  Answer must be 1-15 characters in length.  (Used for documentation only.)
 ;;^DD(9.43,.01,21,0)
 ;;=^^2^2^2920513^^^
 ;;^DD(9.43,.01,21,1,0)
 ;;=The name of a global which is part of this Package.  Used for documentation
 ;;^DD(9.43,.01,21,2,0)
 ;;=only.
 ;;^DD(9.43,.01,"DT")
 ;;=2910827
 ;;^DD(9.43,4,0)
 ;;=DESCRIPTION^9.431^^4;0
 ;;^DD(9.43,4,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.43,4,21,1,0)
 ;;=This is a description of the global and how it is used by the Package.
 ;;^DD(9.43,5,0)
 ;;=JOURNALLING^S^M:mandatory!;O:optional--not required;N:not recommended;^5;1^Q
 ;;^DD(9.43,5,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.43,5,21,1,0)
 ;;=Advises whether or not to Journal this global.
 ;;^DD(9.43,5,"DT")
 ;;=2850228
 ;;^DD(9.431,0)
 ;;=DESCRIPTION SUB-FIELD^NL^.01^1
 ;;^DD(9.431,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(9.431,0,"UP")
 ;;=9.43
 ;;^DD(9.431,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(9.431,.01,21,0)
 ;;=^^1^1^2920513^^^
 ;;^DD(9.431,.01,21,1,0)
 ;;=This is a description of the global and how it is used by the Package.

DIPKI007
DIPKI007 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.431,.01,"DT")
 ;;=2850228
 ;;^DD(9.432,0)
 ;;=*EXCLUDED NAME SPACE SUB-FIELD^NL^.01^1
 ;;^DD(9.432,0,"NM","*EXCLUDED NAME SPACE")
 ;;=
 ;;^DD(9.432,0,"UP")
 ;;=9.4
 ;;^DD(9.432,.01,0)
 ;;=EXCLUDED NAME SPACE^MFX^^0;1^K:$L(X)>7!($L(X)<2)!'(X?1U1UN.UN) X
 ;;^DD(9.432,.01,3)
 ;;=Please enter the prefix of the excluded name space (2-7 characters).
 ;;^DD(9.432,.01,4)
 ;;=W !,?5,"When DIFROM builds '",$P(^DIC(9.4,D0,0),"^",2),"INIT',",!?5,"OPTIONS, FUNCTIONS, SECURITY KEYS, and BULLETINS beginning with",!?5,"these characters WON'T be included.",!
 ;;^DD(9.432,.01,21,0)
 ;;=^^2^2^2851008^
 ;;^DD(9.432,.01,21,1,0)
 ;;=This specifies a sub-set of the Package's namespace which is not to
 ;;^DD(9.432,.01,21,2,0)
 ;;=be exported by the DIFROM routines.
 ;;^DD(9.432,.01,"DT")
 ;;=2841128
 ;;^DD(9.44,0)
 ;;=*FILE SUB-FIELD^NL^223^9
 ;;^DD(9.44,0,"DT")
 ;;=2890928
 ;;^DD(9.44,0,"IX","B",9.44,.01)
 ;;=
 ;;^DD(9.44,0,"NM","*FILE")
 ;;=
 ;;^DD(9.44,0,"UP")
 ;;=9.4
 ;;^DD(9.44,.01,0)
 ;;=FILE^M*P1'^DIC(^0;1^S DIC("S")="I Y>1.9999" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
 ;;^DD(9.44,.01,.1)
 ;;=REQUIRED FILES FOR THIS PACKAGE
 ;;^DD(9.44,.01,1,0)
 ;;=^.1
 ;;^DD(9.44,.01,1,1,0)
 ;;=9.44^B
 ;;^DD(9.44,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),4,"B",X,DA)=""
 ;;^DD(9.44,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),4,"B",X,DA)
 ;;^DD(9.44,.01,1,2,0)
 ;;=9.4^AR
 ;;^DD(9.44,.01,1,2,1)
 ;;=S ^DIC(9.4,"AR",$E(X,1,30),DA(1),DA)=""
 ;;^DD(9.44,.01,1,2,2)
 ;;=K ^DIC(9.4,"AR",$E(X,1,30),DA(1),DA)
 ;;^DD(9.44,.01,3)
 ;;=Please enter the name of a FILE that is known to VA FileMan.
 ;;^DD(9.44,.01,12)
 ;;=Select a file which is used by this package.
 ;;^DD(9.44,.01,12.1)
 ;;=S DIC("S")="I Y>1.9999"
 ;;^DD(9.44,.01,21,0)
 ;;=^^2^2^2920513^^^^
 ;;^DD(9.44,.01,21,1,0)
 ;;=The name of a VA FileMan file which you wish to transport with
 ;;^DD(9.44,.01,21,2,0)
 ;;=this package.  This may be any file whose number is 2 or greater.
 ;;^DD(9.44,.01,"DT")
 ;;=2890928
 ;;^DD(9.44,2,0)
 ;;=FIELD^9.45A^^1;0
 ;;^DD(9.44,2,21,0)
 ;;=^^3^3^2920513^^^
 ;;^DD(9.44,2,21,1,0)
 ;;=The names of the FileMan Fields required by this Package.  Enter data
 ;;^DD(9.44,2,21,2,0)
 ;;=here ONLY if you wish to send just selected fields from a Data Dictionary
 ;;^DD(9.44,2,21,3,0)
 ;;=instead of the entire DD (i.e., a partial DD).
 ;;^DD(9.44,222.1,0)
 ;;=UPDATE THE DATA DICTIONARY^S^y:YES;n:NO;^222;1^Q
 ;;^DD(9.44,222.1,21,0)
 ;;=^^8^8^2920513^^^^
 ;;^DD(9.44,222.1,21,1,0)
 ;;=YES means that the Data Dictionary for this file should be updated when
 ;;^DD(9.44,222.1,21,2,0)
 ;;=this version of the package is installed.
 ;;^DD(9.44,222.1,21,3,0)
 ;;= 
 ;;^DD(9.44,222.1,21,4,0)
 ;;=NO means that this Data Dictionary has not changed since the last version,
 ;;^DD(9.44,222.1,21,5,0)
 ;;=and therefore, need not be updated.
 ;;^DD(9.44,222.1,21,6,0)
 ;;= 
 ;;^DD(9.44,222.1,21,7,0)
 ;;=If the Data Dictionary does not exist on the recipient system, then this
 ;;^DD(9.44,222.1,21,8,0)
 ;;=field does not apply.  The DD will be put in place.
 ;;^DD(9.44,222.1,"DT")
 ;;=2890627
 ;;^DD(9.44,222.2,0)
 ;;=ASSIGN A VERSION NUMBER^S^y:YES;n:NO;^222;2^Q
 ;;^DD(9.44,222.2,3)
 ;;=
 ;;^DD(9.44,222.2,21,0)
 ;;=^^5^5^2920513^^^^
 ;;^DD(9.44,222.2,21,1,0)
 ;;=YES means that you want to set ^DD(file#,0,"VR") to the version
 ;;^DD(9.44,222.2,21,2,0)
 ;;=number of this package when the init is finished.
 ;;^DD(9.44,222.2,21,3,0)
 ;;= 
 ;;^DD(9.44,222.2,21,4,0)
 ;;=NO means that you intend for the version number to remain as it is.
 ;;^DD(9.44,222.2,21,5,0)
 ;;=This may mean that this DD has no version number at all.
 ;;^DD(9.44,222.4,0)
 ;;=MAY USER OVERRIDE DD UPDATE^S^y:YES;n:NO;^222;4^Q
 ;;^DD(9.44,222.4,3)
 ;;=
 ;;^DD(9.44,222.4,21,0)
 ;;=^^5^5^2920513^^^^
 ;;^DD(9.44,222.4,21,1,0)
 ;;=YES means that the user may decide at installation time whether or not
 ;;^DD(9.44,222.4,21,2,0)
 ;;=to update the data dictionary for this file.
 ;;^DD(9.44,222.4,21,3,0)
 ;;= 
 ;;^DD(9.44,222.4,21,4,0)
 ;;=NO means that the developer building the INIT is determining if the
 ;;^DD(9.44,222.4,21,5,0)
 ;;=data dictionary is to be updated.
 ;;^DD(9.44,222.7,0)
 ;;=DATA COMES WITH FILE^S^y:YES;n:NO;^222;7^Q
 ;;^DD(9.44,222.7,21,0)
 ;;=^^4^4^2920513^^^^
 ;;^DD(9.44,222.7,21,1,0)
 ;;=YES means that the data should be included in the initialization
 ;;^DD(9.44,222.7,21,2,0)
 ;;=routines.
 ;;^DD(9.44,222.7,21,3,0)
 ;;= 
 ;;^DD(9.44,222.7,21,4,0)
 ;;=NO means that the data should be left out.

DIPKI008
DIPKI008 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.44,222.7,"DT")
 ;;=2940502
 ;;^DD(9.44,222.8,0)
 ;;=MERGE OR OVERWRITE SITE'S DATA^S^m:MERGE;o:OVERWRITE;^222;8^Q
 ;;^DD(9.44,222.8,3)
 ;;=
 ;;^DD(9.44,222.8,21,0)
 ;;=^^7^7^2920513^^^^
 ;;^DD(9.44,222.8,21,1,0)
 ;;= 
 ;;^DD(9.44,222.8,21,2,0)
 ;;=If the data being sent is to be MERGED, then only data which is not
 ;;^DD(9.44,222.8,21,3,0)
 ;;=already on file at the recipient site will be put in place.
 ;;^DD(9.44,222.8,21,4,0)
 ;;= 
 ;;^DD(9.44,222.8,21,5,0)
 ;;=If the data being sent is to OVERWRITE, then the data included in
 ;;^DD(9.44,222.8,21,6,0)
 ;;=the initialization routines will be put in place regardless of what
 ;;^DD(9.44,222.8,21,7,0)
 ;;=is on file at the recipient site.
 ;;^DD(9.44,222.8,"DT")
 ;;=2890627
 ;;^DD(9.44,222.9,0)
 ;;=MAY USER OVERRIDE DATA UPDATE^S^y:YES;n:NO;^222;9^Q
 ;;^DD(9.44,222.9,3)
 ;;=
 ;;^DD(9.44,222.9,21,0)
 ;;=^^7^7^2920513^^^^
 ;;^DD(9.44,222.9,21,1,0)
 ;;=YES means that the user has the option to determine whether or not
 ;;^DD(9.44,222.9,21,2,0)
 ;;=to bring in the data that has been sent with the package.  However,
 ;;^DD(9.44,222.9,21,3,0)
 ;;=he does not get the ability to change from merge to overwrite or
 ;;^DD(9.44,222.9,21,4,0)
 ;;=from overwrite to merge.
 ;;^DD(9.44,222.9,21,5,0)
 ;;= 
 ;;^DD(9.44,222.9,21,6,0)
 ;;=No means that the developer of the INIT will control whether the data
 ;;^DD(9.44,222.9,21,7,0)
 ;;=will be installed at the target site.
 ;;^DD(9.44,222.9,"DT")
 ;;=2940502
 ;;^DD(9.44,223,0)
 ;;=SCREEN TO DETERMINE DD UPDATE^KX^^223;E1,245^K:$L(X)>240 X I $D(X) D ^DIM
 ;;^DD(9.44,223,3)
 ;;=This is Standard MUMPS code from 1 to 240 characters in length.
 ;;^DD(9.44,223,9)
 ;;=@
 ;;^DD(9.44,223,21,0)
 ;;=^^7^7^2920513^^
 ;;^DD(9.44,223,21,1,0)
 ;;=This field contains standard MUMPS code which is used to determine
 ;;^DD(9.44,223,21,2,0)
 ;;=whether or not a data dictionary should be updated.  This code must
 ;;^DD(9.44,223,21,3,0)
 ;;=set $T.  If $T=1, the DD will be updated.  If $T=0, it will not.
 ;;^DD(9.44,223,21,4,0)
 ;;= 
 ;;^DD(9.44,223,21,5,0)
 ;;=This code will be executed within VA FileMan which may be being called
 ;;^DD(9.44,223,21,6,0)
 ;;=from within MailMan which is being called from within MenuMan.
 ;;^DD(9.44,223,21,7,0)
 ;;=Namespace your variables.
 ;;^DD(9.44,223,"DT")
 ;;=2890927
 ;;^DD(9.444,0)
 ;;=*STATUS SUB-FIELD^NL^2^4
 ;;^DD(9.444,0,"NM","*STATUS")
 ;;=
 ;;^DD(9.444,0,"UP")
 ;;=9.4
 ;;^DD(9.444,.01,0)
 ;;=DATE^DX^^0;1^S %DT="E" D ^%DT S (DINUM,X)=Y K:Y<1 X,DINUM
 ;;^DD(9.444,.01,3)
 ;;=Please enter the date at which the current status took effect.
 ;;^DD(9.444,.01,21,0)
 ;;=^^1^1^2851008^^
 ;;^DD(9.444,.01,21,1,0)
 ;;=This is the date at which the current status took effect.
 ;;^DD(9.444,.01,"DT")
 ;;=2840814
 ;;^DD(9.444,1,0)
 ;;=STATUS^S^A:ASSIGNED;P:PENDING;T:TEMPORARY;X:NO LONGER USED;^0;2^Q
 ;;^DD(9.444,1,21,0)
 ;;=^^2^2^2851008^
 ;;^DD(9.444,1,21,1,0)
 ;;=This specifies the current status of the namespace, i.e. Temporary,
 ;;^DD(9.444,1,21,2,0)
 ;;=Pending, Assigned, etc.
 ;;^DD(9.444,1,"DT")
 ;;=2840814
 ;;^DD(9.444,1.5,0)
 ;;=EXPIRATION DATE^D^^2;1^S %DT="E" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.444,1.5,3)
 ;;=Please enter the date at which the namespace was de-assigned.
 ;;^DD(9.444,1.5,21,0)
 ;;=^^2^2^2851008^^
 ;;^DD(9.444,1.5,21,1,0)
 ;;=This is the date at which the assignment of the namespace to
 ;;^DD(9.444,1.5,21,2,0)
 ;;=this Package expired.
 ;;^DD(9.444,1.5,"DT")
 ;;=2840815
 ;;^DD(9.444,2,0)
 ;;=COMMENTS^9.454^^1;0
 ;;^DD(9.444,2,21,0)
 ;;=^^1^1^2851008^
 ;;^DD(9.444,2,21,1,0)
 ;;=These are any comments about the status of this Package's namespace.
 ;;^DD(9.45,0)
 ;;=FIELD SUB-FIELD^NL^.01^1
 ;;^DD(9.45,0,"IX","B",9.45,.01)
 ;;=
 ;;^DD(9.45,0,"NM","FIELD")
 ;;=
 ;;^DD(9.45,0,"UP")
 ;;=9.44
 ;;^DD(9.45,.01,0)
 ;;=FIELD^MFX^^0;1^S %=+^DIC(9.4,DA(2),4,DA(1),0),X=$S($L(X)>30:X,$D(^DD(%,"B",X)):X,X'?.NP:0,'$D(^DD(%,X,0)):0,1:$P(^(0),U,1)) K:X=0 X
 ;;^DD(9.45,.01,.1)
 ;;=FIELDS REQUIRED FOR THE PACKAGE
 ;;^DD(9.45,.01,1,0)
 ;;=^.1
 ;;^DD(9.45,.01,1,1,0)
 ;;=9.45^B
 ;;^DD(9.45,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(2),4,DA(1),1,"B",X,DA)=""
 ;;^DD(9.45,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(2),4,DA(1),1,"B",X,DA)
 ;;^DD(9.45,.01,3)
 ;;=Please enter the name of a field.
 ;;^DD(9.45,.01,21,0)
 ;;=^^4^4^2920513^^^^
 ;;^DD(9.45,.01,21,1,0)
 ;;=The name of a FileMan field required by this Package.  This field is
 ;;^DD(9.45,.01,21,2,0)
 ;;=only to be filled in if you wish to send only selected fields in

DIPKI009
DIPKI009 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.45,.01,21,3,0)
 ;;=an INIT of this file, instead of the full data dictionary. (i.e.,
 ;;^DD(9.45,.01,21,4,0)
 ;;=a partial DD).
 ;;^DD(9.45,.01,"DT")
 ;;=2840302
 ;;^DD(9.454,0)
 ;;=COMMENTS SUB-FIELD^NL^.01^1
 ;;^DD(9.454,0,"NM","COMMENTS")
 ;;=
 ;;^DD(9.454,0,"UP")
 ;;=9.444
 ;;^DD(9.454,.01,0)
 ;;=COMMENTS^W^^0;1^Q
 ;;^DD(9.454,.01,21,0)
 ;;=^^1^1^2851008^
 ;;^DD(9.454,.01,21,1,0)
 ;;=These are comments about the status of this Package's namespace.
 ;;^DD(9.454,.01,"DT")
 ;;=2840815
 ;;^DD(9.455,0)
 ;;=*KEY VARIABLE SUB-FIELD^NL^1^3
 ;;^DD(9.455,0,"DT")
 ;;=2920928
 ;;^DD(9.455,0,"IX","AB",9.455,.01)
 ;;=
 ;;^DD(9.455,0,"NM","*KEY VARIABLE")
 ;;=
 ;;^DD(9.455,0,"UP")
 ;;=9.4
 ;;^DD(9.455,.01,0)
 ;;=KEY VARIABLE^MF^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>17!($L(X)<1) X
 ;;^DD(9.455,.01,1,0)
 ;;=^.1
 ;;^DD(9.455,.01,1,1,0)
 ;;=9.455^AB
 ;;^DD(9.455,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),1933,"AB",$E(X,1,30),DA)=""
 ;;^DD(9.455,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),1933,"AB",$E(X,1,30),DA)
 ;;^DD(9.455,.01,3)
 ;;=Please enter the name of a MUMPS Variable needed by this Package (1-17 characters).
 ;;^DD(9.455,.01,21,0)
 ;;=^^2^2^2851009^^
 ;;^DD(9.455,.01,21,1,0)
 ;;=The name of a MUMPS variable which the Package would like defined
 ;;^DD(9.455,.01,21,2,0)
 ;;=prior to entry into the routines.
 ;;^DD(9.455,.01,"DT")
 ;;=2850228
 ;;^DD(9.455,.02,0)
 ;;=PURPOSE FOR ERR REPORTS^F^^0;2^K:$L(X)>40!($L(X)<3) X
 ;;^DD(9.455,.02,3)
 ;;=Answer must be 3-40 characters in length.  This will be displayed to indicate the purpose of this variable on error reports
 ;;^DD(9.455,.02,21,0)
 ;;=^^8^8^2920928^
 ;;^DD(9.455,.02,21,1,0)
 ;;=This field is meant to contain a brief description of the purpose or role
 ;;^DD(9.455,.02,21,2,0)
 ;;=of this KEY VARIABLE.  If this variable is present in an error which has
 ;;^DD(9.455,.02,21,3,0)
 ;;=been trapped, and a user selects display of key variables, then this
 ;;^DD(9.455,.02,21,4,0)
 ;;=description will be displayed to aid the user in interpeting the variable
 ;;^DD(9.455,.02,21,5,0)
 ;;=and its value at the time the error occurred.  If this description is not
 ;;^DD(9.455,.02,21,6,0)
 ;;=available, then the variable would not be displayed along with other
 ;;^DD(9.455,.02,21,7,0)
 ;;=annotated key variables.
 ;;^DD(9.455,.02,21,8,0)
 ;;= 
 ;;^DD(9.455,.02,"DT")
 ;;=2920928
 ;;^DD(9.455,1,0)
 ;;=DESCRIPTION^9.456^^1;0
 ;;^DD(9.455,1,21,0)
 ;;=^^2^2^2851008^^
 ;;^DD(9.455,1,21,1,0)
 ;;=This lists information about the MUMPS variable required by this
 ;;^DD(9.455,1,21,2,0)
 ;;=Package.
 ;;^DD(9.456,0)
 ;;=DESCRIPTION SUB-FIELD^NL^.01^1
 ;;^DD(9.456,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(9.456,0,"UP")
 ;;=9.455
 ;;^DD(9.456,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(9.456,.01,21,0)
 ;;=^^2^2^2851008^^
 ;;^DD(9.456,.01,21,1,0)
 ;;=This describes the MUMPS variable which this Package would like
 ;;^DD(9.456,.01,21,2,0)
 ;;=defined prior to entry into the routines.
 ;;^DD(9.456,.01,"DT")
 ;;=2850228
 ;;^DD(9.46,0)
 ;;=*PRINT TEMPLATE SUB-FIELD^NL^2^2
 ;;^DD(9.46,0,"NM","*PRINT TEMPLATE")
 ;;=
 ;;^DD(9.46,0,"UP")
 ;;=9.4
 ;;^DD(9.46,.01,0)
 ;;=PRINT TEMPLATE^MF^^0;1^K:$L(X)>50!($L(X)<2) X
 ;;^DD(9.46,.01,1,0)
 ;;=^.1^^0
 ;;^DD(9.46,.01,3)
 ;;=Please enter the name of a Print Template (2-50 characters).
 ;;^DD(9.46,.01,21,0)
 ;;=^^5^5^2921202^
 ;;^DD(9.46,.01,21,1,0)
 ;;=The name of a Print Template being sent with this Package.
 ;;^DD(9.46,.01,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.46,.01,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.46,.01,21,4,0)
 ;;=separately.  Selected Fields for Export and Export templates cannot be
 ;;^DD(9.46,.01,21,5,0)
 ;;=sent; entering their names here will have no effect.
 ;;^DD(9.46,.01,"DT")
 ;;=2821117
 ;;^DD(9.46,2,0)
 ;;=FILE^RP1'^DIC(^0;2^Q
 ;;^DD(9.46,2,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.46,2,21,1,0)
 ;;=The FileMan file for this Print Template.
 ;;^DD(9.46,2,"DT")
 ;;=2821126
 ;;^DD(9.47,0)
 ;;=*INPUT TEMPLATE SUB-FIELD^NL^2^2
 ;;^DD(9.47,0,"ID",2)
 ;;=W "   FILE #"_$P(^(0),U,2)
 ;;^DD(9.47,0,"NM","*INPUT TEMPLATE")
 ;;=
 ;;^DD(9.47,0,"UP")
 ;;=9.4
 ;;^DD(9.47,.01,0)
 ;;=INPUT TEMPLATE^MF^^0;1^K:$L(X)>50!($L(X)<2) X
 ;;^DD(9.47,.01,1,0)
 ;;=^.1^^0
 ;;^DD(9.47,.01,3)
 ;;=Please enter the name of an Input Template (2-50 characters).
 ;;^DD(9.47,.01,21,0)
 ;;=^^4^4^2920513^^^

DIPKI00A
DIPKI00A ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.47,.01,21,1,0)
 ;;=The name of an Input Template being sent with this Package.
 ;;^DD(9.47,.01,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.47,.01,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.47,.01,21,4,0)
 ;;=separately.
 ;;^DD(9.47,.01,"DT")
 ;;=2821117
 ;;^DD(9.47,2,0)
 ;;=FILE^RP1'^DIC(^0;2^Q
 ;;^DD(9.47,2,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.47,2,21,1,0)
 ;;=The name of the FileMan file for this Input Template.
 ;;^DD(9.47,2,"DT")
 ;;=2821126
 ;;^DD(9.48,0)
 ;;=*SORT TEMPLATE SUB-FIELD^NL^2^2
 ;;^DD(9.48,0,"NM","*SORT TEMPLATE")
 ;;=
 ;;^DD(9.48,0,"UP")
 ;;=9.4
 ;;^DD(9.48,.01,0)
 ;;=SORT TEMPLATE^MF^^0;1^K:$L(X)>50!($L(X)<2) X
 ;;^DD(9.48,.01,1,0)
 ;;=^.1^^0
 ;;^DD(9.48,.01,3)
 ;;=Please enter the name of a Sort Template (2-50 characters).
 ;;^DD(9.48,.01,21,0)
 ;;=^^4^4^2920513^^^
 ;;^DD(9.48,.01,21,1,0)
 ;;=The name of a Sort Template being sent with this Package.
 ;;^DD(9.48,.01,21,2,0)
 ;;=This multiple is used to send non-namespaced templates in an INIT.
 ;;^DD(9.48,.01,21,3,0)
 ;;=Namespaced templates are sent automatically and need not be listed
 ;;^DD(9.48,.01,21,4,0)
 ;;=separately.
 ;;^DD(9.48,.01,"DT")
 ;;=2821117
 ;;^DD(9.48,2,0)
 ;;=FILE^RP1'^DIC(^0;2^Q
 ;;^DD(9.48,2,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.48,2,21,1,0)
 ;;=The FileMan file for this Sort Template.
 ;;^DD(9.485,0)
 ;;=*SCREEN TEMPLATE (FORM) SUB-FIELD^^2^2
 ;;^DD(9.485,0,"DT")
 ;;=2910320
 ;;^DD(9.485,0,"NM","*SCREEN TEMPLATE (FORM)")
 ;;=
 ;;^DD(9.485,0,"UP")
 ;;=9.4
 ;;^DD(9.485,.01,0)
 ;;=SCREEN TEMPLATE (FORM)^MF^^0;1^K:$L(X)>50!($L(X)<2) X
 ;;^DD(9.485,.01,1,0)
 ;;=^.1^^0
 ;;^DD(9.485,.01,3)
 ;;=Please enter the name of a Screen Template (Form), (2-50 characters).
 ;;^DD(9.485,.01,21,0)
 ;;=^^2^2^2920513^^^^
 ;;^DD(9.485,.01,21,1,0)
 ;;=The name of a Screen Template (from the FORM file) associated with
 ;;^DD(9.485,.01,21,2,0)
 ;;=this Package.
 ;;^DD(9.485,.01,23,0)
 ;;=^^3^3^2910320^^^^
 ;;^DD(9.485,.01,23,1,0)
 ;;=This list is originally created by the user for building an INIT, and allows
 ;;^DD(9.485,.01,23,2,0)
 ;;=the user to send FORMS on an INIT that are outside the Package namespace.
 ;;^DD(9.485,.01,23,3,0)
 ;;=All BLOCKS associated with the FORMS are also sent automatically.
 ;;^DD(9.485,.01,"DT")
 ;;=2910320
 ;;^DD(9.485,2,0)
 ;;=FILE^RP1'^DIC(^0;2^Q
 ;;^DD(9.485,2,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.485,2,21,1,0)
 ;;=The name of the FileMan file for this Screen Template (FORM).
 ;;^DD(9.485,2,23,0)
 ;;=^^1^1^2910320^
 ;;^DD(9.485,2,23,1,0)
 ;;=This field must match the PRIMARY FILE field on the FORM file.
 ;;^DD(9.485,2,"DT")
 ;;=2910320
 ;;^DD(9.49,0)
 ;;=VERSION SUB-FIELD^NL^1105^10
 ;;^DD(9.49,0,"DT")
 ;;=2940607
 ;;^DD(9.49,0,"ID",1)
 ;;=W:$D(^("0")) "   ",$E($P(^("0"),U,2),4,5)_"-"_$E($P(^("0"),U,2),6,7)_"-"_$E($P(^("0"),U,2),2,3)
 ;;^DD(9.49,0,"IX","B",9.49,.01)
 ;;=
 ;;^DD(9.49,0,"NM","VERSION")
 ;;=
 ;;^DD(9.49,0,"UP")
 ;;=9.4
 ;;^DD(9.49,.01,0)
 ;;=VERSION^FX^^0;1^K:'(X?1.3N.1".".2N.1A.2N)!(X>999)!(X'>0) X
 ;;^DD(9.49,.01,1,0)
 ;;=^.1
 ;;^DD(9.49,.01,1,1,0)
 ;;=9.49^B
 ;;^DD(9.49,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),22,"B",$E(X,1,30),DA)=""
 ;;^DD(9.49,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),22,"B",$E(X,1,30),DA)
 ;;^DD(9.49,.01,3)
 ;;=Please enter the Version Number of this release.  This can be either the old method (1.0, 16.04, etc.) or the new (17T1, 6.0V2, etc.).
 ;;^DD(9.49,.01,21,0)
 ;;=^^2^2^2930415^^^^
 ;;^DD(9.49,.01,21,1,0)
 ;;=The version number of this Package.  This number is updated automatically
 ;;^DD(9.49,.01,21,2,0)
 ;;=when an INIT is built for this package.
 ;;^DD(9.49,.01,"DT")
 ;;=2910322
 ;;^DD(9.49,1,0)
 ;;=DATE DISTRIBUTED^D^^0;2^S %DT="E" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.49,1,21,0)
 ;;=^^2^2^2911209^^^
 ;;^DD(9.49,1,21,1,0)
 ;;=The date this release was distributed.  This field is updated automatically
 ;;^DD(9.49,1,21,2,0)
 ;;=when an INIT is built for this package.
 ;;^DD(9.49,1,"DT")
 ;;=2840227
 ;;^DD(9.49,2,0)
 ;;=DATE INSTALLED AT THIS SITE^D^^0;3^S %DT="ET" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.49,2,21,0)
 ;;=^^2^2^2911209^^^
 ;;^DD(9.49,2,21,1,0)
 ;;=The date this release was installed at this site.  This field is updated
 ;;^DD(9.49,2,21,2,0)
 ;;=automatically when an INIT is installed for this package.
 ;;^DD(9.49,2,"DT")
 ;;=2840302
 ;;^DD(9.49,3,0)
 ;;=INSTALLED BY^P200'^VA(200,^0;4^Q
 ;;^DD(9.49,3,21,0)
 ;;=^^1^1^2940607^

DIPKI00B
DIPKI00B ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.49,3,21,1,0)
 ;;=This is the person who installed this version at this site.
 ;;^DD(9.49,3,"DT")
 ;;=2940607
 ;;^DD(9.49,41,0)
 ;;=DESCRIPTION OF ENHANCEMENTS^9.54^^1;0
 ;;^DD(9.49,41,21,0)
 ;;=^^2^2^2851008^^
 ;;^DD(9.49,41,21,1,0)
 ;;=This is a description of the enhancements being distributed with this
 ;;^DD(9.49,41,21,2,0)
 ;;=release.
 ;;^DD(9.49,51,0)
 ;;=*RELEASE NOTE^9.491^^R;0
 ;;^DD(9.49,51,21,0)
 ;;=^^2^2^2851009^^^^
 ;;^DD(9.49,51,21,1,0)
 ;;=These are the release notes which go along with this release of the
 ;;^DD(9.49,51,21,2,0)
 ;;=Package.
 ;;^DD(9.49,51,"DT")
 ;;=2940603
 ;;^DD(9.49,61,0)
 ;;=*INSTALLATION NOTES^9.4961^^I;0
 ;;^DD(9.49,61,"DT")
 ;;=2940603
 ;;^DD(9.49,62,0)
 ;;=*SYSTEM REQUIREMENTS^9.4962^^S;0
 ;;^DD(9.49,62,"DT")
 ;;=2940603
 ;;^DD(9.49,63,0)
 ;;=*PROGRAMMER NOTES^9.4963^^P;0
 ;;^DD(9.49,63,"DT")
 ;;=2940603
 ;;^DD(9.49,1105,0)
 ;;=PATCH APPLICATION HISTORY^9.4901^^PAH;0
 ;;^DD(9.4901,0)
 ;;=PATCH APPLICATION HISTORY SUB-FIELD^^1^4
 ;;^DD(9.4901,0,"DT")
 ;;=2940603
 ;;^DD(9.4901,0,"IX","B",9.4901,.01)
 ;;=
 ;;^DD(9.4901,0,"NM","PATCH APPLICATION HISTORY")
 ;;=
 ;;^DD(9.4901,0,"UP")
 ;;=9.49
 ;;^DD(9.4901,.01,0)
 ;;=PATCH APPLICATION HISTORY^MF^^0;1^K:$L(X)>15!($L(X)<8) X
 ;;^DD(9.4901,.01,1,0)
 ;;=^.1
 ;;^DD(9.4901,.01,1,1,0)
 ;;=9.4901^B
 ;;^DD(9.4901,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(2),22,DA(1),"PAH","B",$E(X,1,30),DA)=""
 ;;^DD(9.4901,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(2),22,DA(1),"PAH","B",$E(X,1,30),DA)
 ;;^DD(9.4901,.01,3)
 ;;=Answer must be 8-15 characters in length.
 ;;^DD(9.4901,.01,"DT")
 ;;=2890426
 ;;^DD(9.4901,.02,0)
 ;;=DATE APPLIED^D^^0;2^S %DT="EX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(9.4901,.02,"DT")
 ;;=2890426
 ;;^DD(9.4901,.03,0)
 ;;=APPLIED BY^P200'^VA(200,^0;3^Q
 ;;^DD(9.4901,.03,"DT")
 ;;=2890426
 ;;^DD(9.4901,1,0)
 ;;=DESCRIPTION^9.49011^^1;0
 ;;^DD(9.4901,1,21,0)
 ;;=^^1^1^2940603^
 ;;^DD(9.4901,1,21,1,0)
 ;;=This is a description of the patch being distributed with this release.
 ;;^DD(9.49011,0)
 ;;=DESCRIPTION SUB-FIELD^^.01^1
 ;;^DD(9.49011,0,"DT")
 ;;=2940603
 ;;^DD(9.49011,0,"NM","DESCRIPTION")
 ;;=
 ;;^DD(9.49011,0,"UP")
 ;;=9.4901
 ;;^DD(9.49011,.01,0)
 ;;=DESCRIPTION^W^^0;1^Q
 ;;^DD(9.49011,.01,"DT")
 ;;=2940603
 ;;^DD(9.491,0)
 ;;=*RELEASE NOTE SUB-FIELD^NL^2^4
 ;;^DD(9.491,0,"NM","*RELEASE NOTE")
 ;;=
 ;;^DD(9.491,0,"UP")
 ;;=9.49
 ;;^DD(9.491,.01,0)
 ;;=RELEASE NOTE^MF^^0;1^K:$L(X)>80!($L(X)<3) X
 ;;^DD(9.491,.01,3)
 ;;=Please enter a description (3-80 characters).
 ;;^DD(9.491,.01,21,0)
 ;;=^^1^1^2851008^^
 ;;^DD(9.491,.01,21,1,0)
 ;;=This is a description of a particular enhancement.
 ;;^DD(9.491,.01,"DT")
 ;;=2850123
 ;;^DD(9.491,.02,0)
 ;;=WHERE CHANGE OCCURRED^F^^0;2^K:$L(X)>80!($L(X)<3) X
 ;;^DD(9.491,.02,3)
 ;;=Routine(s), Field Name(s), and/or Data that has been changed (3-80 characters).
 ;;^DD(9.491,.02,21,0)
 ;;=^^1^1^2851009^^^^
 ;;^DD(9.491,.02,21,1,0)
 ;;=Routine, Field Name, or Data that has been changed.
 ;;^DD(9.491,.02,"DT")
 ;;=2850123
 ;;^DD(9.491,1,0)
 ;;=DESCRIPTION OF CHANGE^9.492^^1;0
 ;;^DD(9.491,1,21,0)
 ;;=^^1^1^2851008^^
 ;;^DD(9.491,1,21,1,0)
 ;;=This is a description of the improvements.
 ;;^DD(9.491,2,0)
 ;;=UPDATE^9.493^^2;0
 ;;^DD(9.491,2,21,0)
 ;;=^^2^2^2851009^^
 ;;^DD(9.491,2,21,1,0)
 ;;=Comments on the updates which have been made to this release of the
 ;;^DD(9.491,2,21,2,0)
 ;;=Package.
 ;;^DD(9.492,0)
 ;;=DESCRIPTION OF CHANGE SUB-FIELD^NL^.01^1
 ;;^DD(9.492,0,"NM","DESCRIPTION OF CHANGE")
 ;;=
 ;;^DD(9.492,0,"UP")
 ;;=9.491
 ;;^DD(9.492,.01,0)
 ;;=DESCRIPTION OF CHANGE^W^^0;1^Q
 ;;^DD(9.492,.01,21,0)
 ;;=^^1^1^2851008^^^^
 ;;^DD(9.492,.01,21,1,0)
 ;;=This is a description of the improvement.
 ;;^DD(9.492,.01,"DT")
 ;;=2850123
 ;;^DD(9.493,0)
 ;;=UPDATE SUB-FIELD^NL^.01^1
 ;;^DD(9.493,0,"NM","UPDATE")
 ;;=
 ;;^DD(9.493,0,"UP")
 ;;=9.491
 ;;^DD(9.493,.01,0)
 ;;=UPDATE^W^^0;1^Q
 ;;^DD(9.493,.01,21,0)
 ;;=^^1^1^2851008^
 ;;^DD(9.493,.01,21,1,0)
 ;;=This is a description of the update to the Package.
 ;;^DD(9.493,.01,"DT")
 ;;=2850123
 ;;^DD(9.495,0)
 ;;=*MENU SUB-FIELD^^.02^2
 ;;^DD(9.495,0,"DT")
 ;;=2890928
 ;;^DD(9.495,0,"IX","B",9.495,.01)
 ;;=
 ;;^DD(9.495,0,"NM","*MENU")
 ;;=
 ;;^DD(9.495,0,"UP")
 ;;=9.4
 ;;^DD(9.495,.01,0)
 ;;=MENU^MF^^0;1^K:$L(X)>30!($L(X)<1) X
 ;;^DD(9.495,.01,1,0)
 ;;=^.1
 ;;^DD(9.495,.01,1,1,0)
 ;;=9.495^B
 ;;^DD(9.495,.01,1,1,1)
 ;;=S ^DIC(9.4,DA(1),"M","B",$E(X,1,30),DA)=""
 ;;^DD(9.495,.01,1,1,2)
 ;;=K ^DIC(9.4,DA(1),"M","B",$E(X,1,30),DA)

DIPKI00C
DIPKI00C ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'DIFQ(9.4)  F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DD(9.495,.01,3)
 ;;=This is the name of a menu-type option outside this namespace.
 ;;^DD(9.495,.01,4)
 ;;=N DO,DIC S DIC="^DIC(19,",DIC(0)="QE",D="B",DIC("S")="I $P(^(0),U,4)=""M""" D DQ^DICQ
 ;;^DD(9.495,.01,21,0)
 ;;=^^4^4^2920513^^^^
 ;;^DD(9.495,.01,21,1,0)
 ;;=This is the name of an option NOT in this namespace.  This option
 ;;^DD(9.495,.01,21,2,0)
 ;;=must be a menu, but it may not exist on this system.  You are
 ;;^DD(9.495,.01,21,3,0)
 ;;=entering this menu name because you want to add an option in this
 ;;^DD(9.495,.01,21,4,0)
 ;;=package to a menu that is in another.
 ;;^DD(9.495,.01,"DT")
 ;;=2890928
 ;;^DD(9.495,.02,0)
 ;;=OPTION^R*P19'^DIC(19,^0;2^S DIC("S")="I $P($P(^DIC(19,Y,0),U),$P(^DIC(9.4,DA(1),0),U,2))=""""" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
 ;;^DD(9.495,.02,12)
 ;;=Select an option in this namespace.
 ;;^DD(9.495,.02,12.1)
 ;;=S DIC("S")="I $P($P(^DIC(19,Y,0),U),$P(^DIC(9.4,DA(1),0),U,2))="""""
 ;;^DD(9.495,.02,21,0)
 ;;=^^1^1^2920513^^
 ;;^DD(9.495,.02,21,1,0)
 ;;=This is an option which you wish to add to a menu in another namespace.
 ;;^DD(9.495,.02,"DT")
 ;;=2890928
 ;;^DD(9.4961,0)
 ;;=*INSTALLATION NOTES SUB-FIELD^^.01^1
 ;;^DD(9.4961,0,"NM","*INSTALLATION NOTES")
 ;;=
 ;;^DD(9.4961,0,"UP")
 ;;=9.49
 ;;^DD(9.4961,.01,0)
 ;;=INSTALLATION NOTES^W^^0;1^Q
 ;;^DD(9.4961,.01,"DT")
 ;;=2890426
 ;;^DD(9.4962,0)
 ;;=*SYSTEM REQUIREMENTS SUB-FIELD^^.01^1
 ;;^DD(9.4962,0,"NM","*SYSTEM REQUIREMENTS")
 ;;=
 ;;^DD(9.4962,0,"UP")
 ;;=9.49
 ;;^DD(9.4962,.01,0)
 ;;=SYSTEM REQUIREMENTS^W^^0;1^Q
 ;;^DD(9.4962,.01,"DT")
 ;;=2890426
 ;;^DD(9.4963,0)
 ;;=*PROGRAMMER NOTES SUB-FIELD^^.01^1
 ;;^DD(9.4963,0,"NM","*PROGRAMMER NOTES")
 ;;=
 ;;^DD(9.4963,0,"UP")
 ;;=9.49
 ;;^DD(9.4963,.01,0)
 ;;=PROGRAMMER NOTES^W^^0;1^Q
 ;;^DD(9.4963,.01,"DT")
 ;;=2890426
 ;;^DD(9.54,0)
 ;;=DESCRIPTION OF ENHANCEMENTS SUB-FIELD^NL^.01^1
 ;;^DD(9.54,0,"NM","DESCRIPTION OF ENHANCEMENTS")
 ;;=
 ;;^DD(9.54,0,"UP")
 ;;=9.49
 ;;^DD(9.54,.01,0)
 ;;=DESCRIPTION OF ENHANCEMENTS^W^^0;1^Q
 ;;^DD(9.54,.01,21,0)
 ;;=^^2^2^2851008^^^^
 ;;^DD(9.54,.01,21,1,0)
 ;;=This is a description of the enhancements which are being distributed
 ;;^DD(9.54,.01,21,2,0)
 ;;=with this release.
 ;;^DD(9.54,.01,"DT")
 ;;=2840404

DIPKI00D
DIPKI00D ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DSEC F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^DIC(9.4,0,"DD")
 ;;=#
 ;;^DIC(9.4,0,"DEL")
 ;;=#
 ;;^DIC(9.4,0,"LAYGO")
 ;;=#
 ;;^DIC(9.4,0,"WR")
 ;;=#

DIPKI00E
DIPKI00E ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"PKG",1,0)
 ;;=DIPK (PACKAGE FILE INIT)^DIPK^FileMan Init of Package File
 ;;^UTILITY(U,$J,"PKG",1,1,0)
 ;;=^^2^2^2930702^^^
 ;;^UTILITY(U,$J,"PKG",1,1,1,0)
 ;;=Init of Package file to be used by VA FileMan Site that wish to export
 ;;^UTILITY(U,$J,"PKG",1,1,2,0)
 ;;=software using DIFROM.
 ;;^UTILITY(U,$J,"PKG",1,4,0)
 ;;=^9.44PA^1^1
 ;;^UTILITY(U,$J,"PKG",1,4,1,0)
 ;;=9.4
 ;;^UTILITY(U,$J,"PKG",1,4,1,222)
 ;;=y^y^^n^^^n
 ;;^UTILITY(U,$J,"PKG",1,4,"B",9.4,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,5)
 ;;=SAN FRANCISCO
 ;;^UTILITY(U,$J,"PKG",1,7)
 ;;=SAN FRANCISCO^^I
 ;;^UTILITY(U,$J,"PKG",1,11)
 ;;=9.4^9.4
 ;;^UTILITY(U,$J,"PKG",1,22,0)
 ;;=^9.49I^21^12
 ;;^UTILITY(U,$J,"PKG",1,22,6.5,0)
 ;;=6.5^2900607
 ;;^UTILITY(U,$J,"PKG",1,22,17.78,0)
 ;;=17.78^2900731^2901105
 ;;^UTILITY(U,$J,"PKG",1,22,18.3,0)
 ;;=18.30^2901205
 ;;^UTILITY(U,$J,"PKG",1,22,18.4,0)
 ;;=18.33^2910324^2910801
 ;;^UTILITY(U,$J,"PKG",1,22,18.5,0)
 ;;=19.0T6^2910827^2911210
 ;;^UTILITY(U,$J,"PKG",1,22,18.6,0)
 ;;=19.0V9^2911212^2911217
 ;;^UTILITY(U,$J,"PKG",1,22,18.7,0)
 ;;=19.0V10^2920420^2920420
 ;;^UTILITY(U,$J,"PKG",1,22,18.8,0)
 ;;=19.0^2920714^2920824
 ;;^UTILITY(U,$J,"PKG",1,22,18.9,0)
 ;;=20.0^2930702^2940912
 ;;^UTILITY(U,$J,"PKG",1,22,19,0)
 ;;=21.0V01^2940920
 ;;^UTILITY(U,$J,"PKG",1,22,20,0)
 ;;=21.0V02^2941025
 ;;^UTILITY(U,$J,"PKG",1,22,21,0)
 ;;=21.0^2941222
 ;;^UTILITY(U,$J,"PKG",1,22,"B",6.5,6.5)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B",17.78,17.78)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B",18.33,18.4)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","18.30",18.3)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","19.0",18.8)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","19.0T6",18.5)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","19.0V10",18.7)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","19.0V9",18.6)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","20.0",18.9)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","21.0",21)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","21.0V01",19)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,22,"B","21.0V02",20)
 ;;=
 ;;^UTILITY(U,$J,"PKG",1,"DEV")
 ;;=TKW/SF
 ;;^UTILITY(U,$J,"PKG",1,"DIBT",0)
 ;;=^9.48^^0
 ;;^UTILITY(U,$J,"PKG",1,"DIPT",0)
 ;;=^9.46^^0
 ;;^UTILITY(U,$J,"PKG",1,"INI")
 ;;=^
 ;;^UTILITY(U,$J,"PKG",1,"INIT")
 ;;=^
 ;;^UTILITY(U,$J,"SBF",9.4,9.4)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.402)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.404)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.409)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.41)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.414)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.42)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.43)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.431)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.432)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.44)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.444)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.45)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.454)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.455)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.456)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.46)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.47)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.48)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.485)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.49)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.4901)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.49011)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.491)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.492)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.493)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.495)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.4961)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.4962)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.4963)
 ;;=
 ;;^UTILITY(U,$J,"SBF",9.4,9.54)
 ;;=

DIPKINI1
DIPKINI1 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK ;I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 ;Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^DIPKI" F R=1:1:14 D @(DN_$$B36(R)) W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 Q
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;FORM
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)

DIPKINI2
DIPKINI2 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R=""  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

DIPKINI3
DIPKINI3 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X=""  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^DIPKINI4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D
 .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
 .Q
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 I N="DIST(.403," D
 .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA)
 .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q
 .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled"
 .Q
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D
 .N X S X=0
 .F  S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X)
 .Q
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D
 .N X S X=0
 .F  S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X=""  S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X)
 .Q
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q
KAD(D0) N D1,X
 S X=0 F  S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0  S D1=0 F  S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0  K ^DIC(19,"AD",X,D0,D1)
 Q

DIPKINI4
DIPKINI4 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

DIPKINI5
DIPKINI5 ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:2 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;DIPK (PACKAGE FILE INIT)^DIPK
 ;;9.4I;PACKAGE;^DIC(9.4,;0;y;y;;n;;;n
 ;;

DIPKINIS
DIPKINIS ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PAC(PKG,VER) ; called from package init (DIFROM7 created this routine)
 ; PKG = $T(IXF) of the INIT routine.
 ; VER is an array that is contained in DIFROM from the INIT routine
 ;
 N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("DIPKINIS",$J)
 ;
 ; Site tracking updates only occur if run in a VA production primary domain
 ; account.
 I $G(^XMB("NETNAME"))'[".VA.GOV" Q
 Q:'$D(^%ZOSF("UCI"))  Q:'$D(^%ZOSF("PROD"))
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q
 ;
 S SERVER="S.A5CSTS@FORUM.VA.GOV"
 S PACKAGE=$P($P(PKG,";",3),U)
 S SITE=$G(^XMB("NETNAME"))
 S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown"
 D  ; check if ok to use kernel functions
 .S X="XLFDT" X ^%ZOSF("TEST") I $T D  Q
 ..S NOW=$$HTFM^XLFDT($H)
 ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3)
 ..S START=$$FMTE^XLFDT(START)
 ..S DATE=NOW\1
 ..S NOW=$$FMTE^XLFDT(NOW)
 .D NOW^%DTC S NOW=%,DATE=X
 .S RUN="" ; don't bother to compute
 .S Y=START D DD^%DT S START=Y
 .S Y=NOW D DD^%DT S NOW=Y
 ;
 ; Message for server
 S ^TMP("DIPKINIS",$J,1,0)="PACKAGE INSTALL"
 S ^TMP("DIPKINIS",$J,2,0)="SITE: "_SITE
 S ^TMP("DIPKINIS",$J,3,0)="PACKAGE: "_PACKAGE
 S ^TMP("DIPKINIS",$J,4,0)="VERSION: "_VER
 S ^TMP("DIPKINIS",$J,5,0)="Start time: "_START
 S ^TMP("DIPKINIS",$J,6,0)="Completion time: "_NOW
 S ^TMP("DIPKINIS",$J,7,0)="Run time: "_RUN
 S ^TMP("DIPKINIS",$J,8,0)="DATE: "_DATE
 ;
 ; Data is sent to server on FORUM - S.A5CSTS
 S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""DIPKINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION"
 D ^XMD
 K ^TMP("DIPKINIS",$J)
 Q

DIPKINIT
DIPKINIT ; ; 22-DEC-1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S DIOVRD=1,U="^",DIFQ=0,DIFROM="21.0" W !,"This version (#21.0) of 'DIPKINIT' was created on 22-DEC-1994"
 W !?9,"(at FILEMAN 21 DEVELOPMENT AREA, by VA FileMan V.21.0V03)",!
 I $D(^DD("VERSION")),^("VERSION")'<21 G GO
 ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^DIPKINI"_$E("5",DIFRIR) D @DIFRRTN
 W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:2 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="21.0" D PKG:'$D(DIFROM(0)),^DIPKINI1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^DIPKINI2,^DIPKINI3
 L  S DUZ=DIDUZ W:1 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 I DIFROM,$D(^%ZTSK) S X="DIPKINIS" X ^%ZOSF("TEST") D:$T PAC^DIPKINIS($T(IXF),.DIFROM)
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^DIPKINI2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W $C(7),!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;DIPK (PACKAGE FILE INIT)^DIPK;3

DIPOST
DIPOST ;IRMFO-SF/FM STAFF-POST INSTALL ROUTINE;7/26/96  15:00
 ;;21.0;VA FileMan;**8**;Dec 28,1994
 ;Per VHA Directive 10-93-142, this routine should not be modified
 Q
 ;
V21P8 ;21*8
 N DIK,DA S DIK="^DD(1.14,",DA(1)=1.14 D IXALL^DIK
 K ^DD(.4,8,1,2),^DD(.4,0,"IX","EX",.4,8),^DIPT("EX")
 Q
 ;

DIPT
DIPT ;SFISC/XAK,TKW-DISPLAY PRINT OR SORT TEMPLATE ;4/6/93  9:28 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:'$D(^DIPT(D0,0))  S (DRK,J(0))=$P(^(0),U,4),L=0,DS(1)=0,D(L)="0FIELD",C=",",Q="""",D9="",Y=2
 F DS(1)=0:0 S DS(1)=$O(^DIPT(D0,"F",DS(1))) Q:DS(1)=""  S DY=^(DS(1)) D Y
 D:D9]"" UP F D=2:1 Q:'$D(DS(D))  S X=DS(D) W !?DIWD(D)*2,$S(D=2:"FIRST",1:"THEN")_$S($G(DDXP)=3:" EXPORT ",1:" PRINT ")_$P(DIWD(D),+DIWD(D),2)_": "_X_"//" I '$D(D) K DD
 W ! K DS,DIWD,D,DRK,J S X="" Q
Y ;
 S X=$P(DY,$C(126),1),DY=$P(DY,$C(126),2,99) Q:X=""
 I D9]"" G UP:$P(X,D9,1)]"" S X=$P(X,D9,2,99)
R I X'>0 G 0:$E(X,2)'=C&'X S:+X D9=D9_+X_C,DRK=-X S:X<0 L=L+1,D(L)=L_$P(^DIC(DRK,0),U,1)_" FIELD" G M
 G NC:X'[C S DA=$P(X,C,1) G NC:+DA'=DA
 S:DA<0 DA=-DA G Y:'$D(^DD(DRK,DA,0)) S X=$P(X,C,2,99),DS(Y)=$P(^(0),U,1),%=+X,D=+$P(^(0),U,2),DIWD(Y)=L_$P(^DD(DRK,0),U,1) G Y:'$D(^DD(D,.01,0)),W:$P(^(0),U,2)["W" S DRK=D,D9=D9_DA_C,Y=Y+1,L=L+1,(DIWD(Y),D(L))=L_$P(^DD(D,0),U,1) G R
NC S %=+X,D=DRK_U_% I $D(^DIPT(D0,"DCL",D)) S X=X_$E(^(D),$L(^(D)))
 G Y:'$D(^DD(DRK,%,0))
W S X=$P(^(0),U,1)_$E(X,$L(%)+1,999)
P S DS(Y)=X,DIWD(Y)=D(L),Y=Y+1 G Y
0 S:X?1"0".E X="NUMBER"_$E(X,2,999)
M S %=$F(X,";Z;""") I '% S D=X G P
 S %=%-$L($P(X,";",1)),X=";"_$P(X,";",2,99) F D=%:0 S D=$F(X,Q,D) I ";"[$E(X,D) S X=$E(X,%,D-2)_$E(X,1,%-5)_$E(X,D,999) G P
 ;
UP S DRK=J(0),%=D9,DA=""
DOWN I X[C,+X=$P(X,C,1),$P(D9,DA_+X_C,1)="" S DA=DA_+X_C,%=$P(%,C,2,99),DRK=$S(X'>0:-X,1:+$P(^DD(DRK,+X,0),U,2)),X=$P(X,C,2,99) G DOWN
NUL S D9=DA,DS(Y)="",DIWD(Y)=D(L),L=L-1,Y=Y+1,%=$P(%,C,2,99) G NUL:%]"",R
 ;
DIBT ; DISPLAY SORT FIELDS
 I '$D(^DIBT(D0,0))!'$D(^(2)) S X="" Q
 K DIPP,DPP N DIBTRPT,DIBTOLD,C,D
 S X=D0,(DJ,DIBTRPT)=1,C=",",D="^DIBT("_D0_"," D ENDIPT^DIP11 S X="" K DIBTRPT
 F DIJ=0:0 S DIJ=$O(DPP(DIJ)) Q:DIJ=""  S DIPP(DIJ)=DPP(DIJ),%=+DPP(DIJ),DJ=DIJ D E1^DIP0 S %X=0 D E2^DIP0
 K DPP,DIJJ F DIJ=0:0 S DIJ=$O(DIPP(DIJ)) Q:DIJ=""  D DJ
 K DIPP,DIJ,DPP,DJ,%X,%Y,C S X="" Q
 ;
DJ W !?DIJ*2-2,$S(DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_$P($P(DIPP(DIJ),U,4),"""",1)_$P(DIPP(DIJ),U,3)_$P(DIPP(DIJ),U,5)_"//" S DPP(DIJ)=$P(DIPP(DIJ),U,3)
 I $D(^DD(+DIPP(DIJ),+$P(DIPP(DIJ),U,2),0)) S X=+$P(^(0),U,2) I X,$D(DIPP(DIJ,X)),$D(^DD(X,0)) W !?DIJ*2-2,$P(^(0),U,1)_": "_DIPP(DIJ,X)_"//" K DIPP(DIJ,X)
 F %=0:0 S %=$O(DIPP(DIJ,%)) Q:'%  I $D(DIPP(DIJ,%))#2 W !?DIJ*2-2,$S('$D(^DD(%,0,"UP")):$O(^("NM",0))_" ",1:""),$P(^DD(%,0),U,1)_": "_DIPP(DIJ,%)_"//" S DPP(DIJ)=DIPP(DIJ,%)
 I $D(^DIBT(D0,2,DIJ,"ASK")) W "    (User is asked range)" Q
 Q:'$D(^DIBT(D0,2,DIJ,"F"))&('$D(^("TXT")))
 I $D(^DIBT(D0,2,DIJ,"TXT")) W " ("_^("TXT")_")" Q
 S Y=^("F"),%Y=$S('$D(^("T")):"",^("T")="z":"",1:^("T")) S:Y[".9999" Y=$P(Y,".",1)+1 X:Y?1"2"6N.NP ^DD("DD") S %=$F(Y,"z"),X="     From '"_$S(%:$E(Y,1,%-3)_$C($A(Y,%-2)+1),1:Y)_"'",Y=%Y
 I Y]"" S:Y[".9999" Y=Y\1 X:Y?1"2"6N.NP ^DD("DD") S X=X_"  To '"_Y_"'"
 W X

DIPZ
DIPZ ;SFISC/XAK,TKW-COMPILE PRINT TEMPLATES ;4/14/95  09:19
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) Q
EN1 N DNM,X,Y,Z D K I '$D(DISYS) N DISYS D OS^DII
 I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q
 S DTIME=$S('$D(DTIME):300,1:DTIME)
 D SIZ^DIPZ0(8034) G:$D(DTOUT)!$D(DUOUT)!'X K S DMAX=X
TEM K DIC S DIC="^DIPT(",DIC(0)="AIEQ"
 S DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")"
 S DIC("S")="I $D(^(""F""))>9,'$P(^(0),U,8),Y'<1" D ^DIC G K:Y<0
 S DIPZ=+Y
 D RNM^DIPZ0(8034) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC
IOM K DIR S DIR("B")=$G(^DIPT(DIPZ,"IOM")) K:'DIR("B") DIR
 S DIR(0)="N^19:255",DIR("A")=$$EZBLD^DIALOG(8022) D BLD^DIALOG(8023,"","","DIR(""?"")")
 D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!'X K S IOM=X
 W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G K:'Y!($D(DIRUT))
 S X=DNM,Y=DIPZ D ENZ
K K DMAX,DIC,DCL,R,M,DE,DI,DPP,DIPZ,DHD,DIWL,DIWR,DK,DP,DNP,DCL,DITTO,DUOUT,DIRUT,DIROUT,DTOUT
 K %,%H,I,O,C,D,DD,DHT,DIL0,DIP,DN,DU,F,H,L,N,S,Q,CP,DINC Q
 ;
EN ;
 Q:'$D(^DIPT(Y,"IOM"))!($P($G(^DIPT(Y,0)),U,8))  S IOM=^("IOM") D ENZ G K
 ;
ENZ S (R,DCL,DPP)=0 F %=0:0 S R=$O(^DIPT(+Y,"DCL",R)) Q:R=""  F %=1:1 Q:%>$L(^(R))  S Z=$E(^(R),%) I Z?1P S DCL(R)=$G(DCL(R))_Z
ENDIP ;
 W:'$G(DIPZS) ! K ^UTILITY($J),^("DIL",$J),^UTILITY("DIPZ",$J),DIPZ,DNP,DIPZLR,DRN,DIPZL,DX,DXS,R N DIPZQ S DIPZQ=0
 S DNM=X,DIPZ=+Y,DRD=0,DP=$P(^DIPT(DIPZ,0),U,4),DHD=$S(^("H")="@":"@",1:3) S:$D(^("DNP")) DNP=1
 S DK=^DIC(DP,0,"GL"),DMAX=DMAX-$S($D(DCL)>9:1600,1:1300),DRN=0,R="",L=0,DINC=1
 I '$D(IOM) Q:$D(^DIPT(DIPZ,"IOM"))[0  S IOM=^("IOM")
AF D DT^DICRW,INIT^DIP5 S X=-1
 S T(1)=$P(^DIPT(DIPZ,0),U),T(2)=$$EZBLD^DIALOG(8034),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR")
 W:'$G(DIPZS) !,DIR K DIR
 F T=0:0 S X=$O(^DIPT("AF",X)) Q:X=""  F %=0:0 S %=$O(^DIPT("AF",X,%)) Q:'%  K:$D(^(%,DIPZ)) ^(DIPZ)
 F C=1:1 Q:'$D(^DIPT(DIPZ,"DXS",C,9.2))&'$D(^(9))  D DXS S:DIDXS DXS(C)=""
 S DL=1,DIPZL=0,DHT=-1,C=",",Q="""",^UTILITY($J,1)=""
 F DIP=-1:0 S DIP=$O(^DIPT(DIPZ,"F",DIP)) Q:DIP=""  S R=^(DIP) D ^DIL
 D UNSTACK^DIL:DM,A^DIL,T^DIL2 K ^DIPT(DIPZ,"T") F R=-1:0 S R=$O(^UTILITY($J,"T",R)) Q:R=""  S ^DIPT(DIPZ,"T",R)=^(R)
 S DX=DX+999,Y=$P(" D ^DIWW",1,''$D(DIWR))_" K Y" I DIWL S Y=Y_" K DIWF" S:DIWL=1 ^UTILITY("DIPZ",$J,.5)=" S DIWF=""W"""
 D PX^DIPZ1 G ^DIPZ2
DXS S DIDXS=1
 I $D(^DIPT(DIPZ,"DXS",C,9)) S X=^(9) D ^DIM I '$D(X) S DIDXS=0
 Q
 ;
EN2(Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZZMSG) ;Silent or Talking with parameter passing
 ;and optionally return list of routines built and if successful
 ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY
 ;Y=TEMPLATE IEN (required)
 ;FLAGS="T"alk (optional)
 ;X=ROUTINE NAME (required)
 ;DMAX=ROUTINE SIZE (optional)
 ;DIPZRLA=ROUTINE LIST ARRAY, by value (optional)
 ;DIPZZMSG=MESSAGE ARRAY (optional) (default ^TMP)
 ;*
 ;DIPZS will be used to indicate "silent" if set to 1
 ;Write statements are made conditional, if not "silent"
 ;*
 N DIPZS,DNM,DIQUIET,DIPZRIEN,DIPZRLAZ,Z,DIPZRLAF
 N DIK,DIC,%I,DICS
 S DIPZS=$G(DIPZFLGS)'["T"
 S:DIPZS DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D
 .N Y,DIPZFLGS,X,DMAX,DIPZRLA,DIPZS
 .D INIZE^DIEFU
 I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Print Template missing or invalid") G EN2E
 I '$D(^DIPT(Y,0)) D BLD^DIALOG(1700,"No Print Template on file with IEN="_Y) G EN2E
 I $G(^DIPT(Y,"IOM"))'>0 D BLD^DIALOG(1700,"No Margin Width for Print Template, IEN="_Y) G EN2E
 I $P($G(^DIPT(Y,0)),"^",8) D BLD^DIALOG(1700,"Print Template Invalid, IEN="_Y) G EN2E
 I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Print Template, IEN="_Y) G EN2E
 I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E
 I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E
 S DIPZRLA=$G(DIPZRLA,"DIPZRLAZ"),DIPZRIEN=Y
 S:DIPZRLA="" DIPZRLA="DIPZRLAZ" S:$G(DMAX)'>0!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU")
 S DIPZRLAF=""
 K @DIPZRLA
 D EN
 G:'DIPZS!(DIPZRLAF) EN2E
 D BLD^DIALOG(1700,"Compiling Print Template (IEN="_DIPZRIEN_")"_$S(DIPZRLAF=0:", routine name too long",1:""))
EN2E I 'DIPZS D MSG^DIALOG() Q
 I $G(DIPZZMSG)]"" D CALLOUT^DIEFU(DIPZZMSG)
 Q
 ;
 ;DIALOG #101    'only those with programmer's access'
 ;       #820    'no way to save routines on the system'
 ;       #8020   'Should the compilation run now?'
 ;       #8022   'Margin Width for output.'
 ;       #8023   'Type a number from 19 to 255.  This is the number...'
 ;       #8024   'Compiling template name Print template of file n'
 ;       #8034   'Print template'

DIPZ0
DIPZ0 ;SFISC/TKW-COMPILE PRINT TEMPLATES ;12/12/94  14:53
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
SIZ(DITYP) ;PROMPT FOR SIZE OF COMPILED ROUTINE
 ;PARAMETER DITYP CONTAINS A NUMBER IN DIALOG FILE POINTING TO EITHER
 ;TEXT FOR A TEMPLATE TYPE, OR TO THE TEXT 'CROSS-REFERENCES'.
 N %,DIR
 S %=$P($G(^DD("OS",DISYS,0)),U,4) S:'% %=$G(^DD("ROU")) S:'% %=5000
 S DIR(0)="N^2400:"_%_":0",DIR("B")=%,DIR("A")=$$EZBLD^DIALOG(8027)
 K % S %(1)=$$EZBLD^DIALOG(DITYP) D BLD^DIALOG(9002,.%,"","DIR(""?"")")
 D ^DIR Q
 ;
RNM(DITYP) ;PROMPT FOR COMPILED ROUTINE NAME
 ;PARAMETER SAME AS FOR SIZ.
 N %,DIR,DIRNM
 S DIRNM="" D
 .I DITYP<8036 S DIRNM=$G(@(DIC_DIPZ_",""ROUOLD"")")),DIRNM(1)=$G(@(DIC_DIPZ_",""ROU"")"))
 .E  S DIRNM=$G(@("^DD("_DIPZ_",0,""DIKOLD"")")),DIRNM(1)=$G(@("^DD("_DIPZ_",0,""DIK"")")) S:DIRNM="" DIRNM=DIRNM(1)
 .Q
 I DIRNM(1)]"" S DIR(0)="Y",DIR("B")="NO" D  D ^DIR K DIR Q:$D(DIRUT)  I Y D UNC Q
 .K % S %(1)=$$EZBLD^DIALOG(DITYP),%(2)=DIRNM(1)
 .D BLD^DIALOG(8028,.%,"","DIR(""A"")")
 .K %(2) D BLD^DIALOG(9004,.%,"","DIR(""?"")")
 .Q
 S %=7 ;S:DITYP=8036 %=6
 S DIR(0)="F^3:"_%_"^K:X'?1U.NU&(X'?1""%""1U.NU)!(X?1""DI"".E) X" S:DIRNM]"" DIR("B")=DIRNM
 D BLD^DIALOG(8001,"","","DIR(""A"")"),BLD^DIALOG(9006,%,"","DIR(""?"")")
 D ^DIR K DIR Q:$D(DIRUT)!(X="")
 I $L(X)>6 D
 .N A,% D BLD^DIALOG(8031,"","","A") W $C(7),! F %=0:0 S %=$O(A(%)) Q:'%  W A(%),!
 .W ! Q
 I $$ROUEXIST^DILIBF(X) K % S %(1)=U_X D BLD^DIALOG(8016,.%,"","DIR") W $C(7),!?5,DIR K DIR
 Q
UNC ;UNCOMPILE TEMPLATES/CROSS-REFS
 N %,DIR I DITYP<8036 K @(DIC_DIPZ_",""ROU"")")
 E  K @("^DD("_DIPZ_",0,""DIK"")")
 S %(1)=$$EZBLD^DIALOG(DITYP) D BLD^DIALOG(8026,.%,"","DIR(""A"")")
 W $C(7),!!,DIR("A")
 S X="" Q
 ;
 ;DIALOG #8001  'Routine Name'
 ;       #8016  'Note that...is already in the routine directory'
 ;       #8027  'Maximum routine size on this computer...'
 ;       #8028  '...currently compiled under namespace...UNCOMPILE...'
 ;       #8031  'WARNING!!  Since the namespace...routine...so long...'
 ;       #8033  'Input template'
 ;       #8034  'Print Template'
 ;       #8036  'Cross-Reference(s)'
 ;       #9002  'This number will be used to determine how large...'
 ;       #9004  'Answer YES to UNCOMPILE the ...'
 ;       #9006  'Enter a valid MUMPS routine name...'

DIPZ1
DIPZ1 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;04:03 PM  22 Aug 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PX ;
 F DX=DX+1:1 I '$D(^UTILITY("DIPZ",$J,DX)) S ^(DX)=" "_$E(Y,2,999) Q
 W:'$G(DIPZS) "." S O=0,DIPZL=$L(Y)+DIPZL+2 I DIPZL>DMAX S DRN(DRN)=DX,^(DX+1)=^(DX),DIPZL=$L(Y)+2,DRN=DRN+1,^(DX)=" G ^"_DNM_DRN,DX=DX+1
 Q
 ;
DE ;
 D SUBNAME S DX=F(DM-1),^(DX)=^(DX)_" D "_X
D S DIPZL(DM)=DX+1,DIPZLR(DM)=DRN,^(DX+1)=" G "_X_"R",^(DX+2)=X_" ;",DX=DX+2 Q
 ;
DIWR ;
 S I=$D(^UTILITY("DIPZ",$J,1)) I $D(DIWR(DM)),DX=DIWR(DM) S ^(DX)=" D A^DIWW"
 E  I $D(DIWR(DM)) S DX=DX+1,^(DX)=" D ^DIWW"
 E  F I=DM-1:-1:0 I $D(DIWR(I)) K DIWR(I) S I=F(I),^(I-.1)=" D ^DIWW" Q
 K DIWR(DM) Q
 ;
WP ;
 S I=$E(^UTILITY("DIPZ",$J,X),2,999) D WPX^DIL0 S ^UTILITY("DIPZ",$J,X)=" "_I Q
 ;
DREL ;
 S %=X,DHT=Y,DM=DM+1 D SUBNAME F DX=DX+1:1 I '$D(^UTILITY("DIPZ",$J,DX)) S ^(DX)=" S DIXX("_DM_")="""_X_""""_% Q
 D D S DX=DX+2,^(DX-1)=" I $D(DSC("_DP_")) X DSC("_DP_") E  Q",^(DX)=" W:$X>"_DG_" !"_DHT,DHT=-1,F=F_+W_C,DIL=DIL+1,DD=DD-1,%=DX Q
 ;
UP ;
 S ^UTILITY("DIPZ",$J,DX+1)=" Q",X=DIPZ(DM) D X
 S (F(DM-1),DX)=DX+2,^UTILITY("DIPZ",$J,DX)=X_"R ;" S:DIPZLR(DM)'=DRN ^(DIPZL(DM))=^(DIPZL(DM))_"^"_DNM_DRN Q
 ;
SUBNAME S (DIPZ(DM),X)=$G(DIPZ(DM))+1
X S X=$S(X<27:$C(64+X),1:$C(X\26+64,X#26+65))_DM Q

DIPZ2
DIPZ2 ;SFISC/GFT,XAK-COMPILE PRINT TEMPLATES ;9/20/94  14:21
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F R=0:0 S R=$O(DXS(R)),W="" Q:'R  K:$D(DXS(R))>9 ^DIPT(DIPZ,"DXS",R) F R=R:0 S W=$O(DXS(R,W)) Q:W=""  S ^DIPT(DIPZ,"DXS",R,W)=DXS(R,W)
 S DIPZLR=DRN,DRN="",DIL=0 D NEW I $D(^DIPT(DIPZ,"DXS")) S X=" I $D(DXS)<9 F X=0:0 S X=$O(^DIPT("_DIPZ_",""DXS"",X)) Q:'X  S Y=$O(^(X,"""")) F X=X:0 Q:Y=""""  S DXS(X,Y)=^(Y),Y=$O(^(Y))" D L
DIL S DIL=$O(^UTILITY("DIPZ",$J,DIL)) G DHD:'DIL
 S DHT=^(DIL) I DRN<DIPZLR,DIL>DRN(+DRN) D SAVE G:DIPZQ K
 S X=DHT D L G DIL
 ;
DHD F F=2.9:0 S F=$O(^UTILITY($J,F)) Q:'F  S DIL=$L(^(F))+DIL
 I DIL+DIPZL>DMAX D SAVE G:DIPZQ K
 S X=" Q" D L S X="HEAD ;" D L F F=2.9:0 S F=$O(^UTILITY($J,F)) Q:'F  S X=" "_^(F) D L
 S X=" W !,""" F %=1:1 S X=X_"-" I %=IOM!(%>239) S X=X_""",!!" D L Q
END D SAVE G:DIPZQ K
 S ^DIPT(DIPZ,"ROUOLD")=DNM,^("IOM")=IOM,^("ROU")=U_DNM,^("LAST")=$S(DRN>1:DRN-1,1:""),DM=0,F=""
 K ^("STATS"),DXS F DIP="L","H","DITTO","CP","Q","N","S" I $D(@DIP)>9 S %X=DIP_"(",%Y="^DIPT(DIPZ,""STATS"",DIP," D %XY^%RCR
 F DIP=-1:0 S DIP=$O(^DIPT(DIPZ,"F",DIP)) Q:DIP=""  S R=^(DIP) W:'$G(DIPZS) "." D R
K K ^UTILITY($J),^("DIPZ",$J),DIPZL,DISMIN,%X,%Y,DG,DIL,DLN,DL,DM,DMAX,DNM,DRD,DRJ,DIO,DX,DY,DRN,DIPZLR,V,R,W,Y,T,DIDXS,DINC
 Q
 ;
R Q:R=""  S W=$P(R,$C(126),1),R=$P(R,$C(126),2,999)
DM I DM G UP:$P(W,F,1)]"" S W=$P(W,F,2,999)
 I 'W S:W?1"0".E ^DIPT("AF",DP,.001,DIPZ)="" G R
 I $P(W,";",1)=+W S ^DIPT("AF",DP,+W,DIPZ)="" G R
 G R:W'?.NP1",".E I W<0 S X=-W G DOWN
 G R:'$D(^DD(DP,+W,0)) S X=+$P(^(0),U,2) G R:'X
DOWN S DM=DM+1,DP(DM)=DP,DP=X,F=F_+W_C G DM
UP S DP=DP(DM),DM=DM-1,F=$P(F,C,1,DM)_$E(C,DM>0) G DM
 ;
SAVE ;
 S L=1.001,DINC=.001 S X=" G BEGIN" D L,OS^DII:'$D(DISYS) F %=$S($D(DCL)>9:1,0'[DCL:7,1:10):1 S X=$E($T(TEXT+%),4,999) Q:X=""  D L
 I $L(DNM_DRN)>8 S DIPZQ=1 W:'$G(DIPZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIPZRLA)]"" DIPZRLAF=0 Q
 S X=DNM_DRN X ^DD("OS",DISYS,"ZS") S %(1)=X D BLD^DIALOG(8025,.%,"","DIR") W:'$G(DIPZS) !,DIR K %,DIR S:$G(DIPZRLA)]"" @DIPZRLA@(DNM_DRN)="",DIPZRLAF=1
 S DRN=DRN+1
NEW K ^UTILITY($J,0) S X=DNM_DRN_" ; GENERATED FROM '"_$P(^DIPT(DIPZ,0),U,1)_"' PRINT TEMPLATE (#"_DIPZ_") ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
 S X=X_" ; ("_$S(DRN="":"FILE "_DP_", MARGIN="_IOM_")",1:"continued)"),L=1,DINC=1,^UTILITY($J,0,L)=X
 S X=" S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)"
L S L=L+DINC,^UTILITY($J,0,L)=X Q
 ;
 ;DIALOG #1503  'routine name is too long.  Compilation...aborted'
 ;       #8025  '...routine filed.'
 ;
TEXT ;
 ;;CP G CP^DIO2
 ;;C S DQ(C)=Y
 ;;S S Q(C)=Y*Y+Q(C) S:L(C)>Y L(C)=Y S:H(C)<Y H(C)=Y
 ;;P S N(C)=N(C)+1
 ;;A S S(C)=S(C)+Y
 ;; Q
 ;;D I Y=DITTO(C) S Y="" Q
 ;; S DITTO(C)=Y
 ;; Q
 ;;N W !
 ;;T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
 ;; S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP^DIO2
 ;; Q
 ;;DT I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
 ;; I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
 ;; W Y Q
 ;;M D @DIXX
 ;; Q
 ;;BEGIN ;

DIQ
DIQ ;SFISC/GFT-CAPTIONED TEMPLATE ;1/25/95  13:54
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 G INQ^DII
 ;
GET1(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;Extrinsic Function
 ; file,record,field,parm,targetarray,errortargetarray,internal
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 G DDENTRY^DIQG
 ;
GETS(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;Procedure Call
 ; file,record,field,parm,targetarray,errortargetarray,internal
 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
 N DIQGQERR
 D DDENTRY^DIQGQ
 I $G(DIQGQERR)]"" S DIERR=DIQGQERR
 D:$G(DIQGERRA)]"" CALLOUT^DIEFU(DIQGERRA)
 Q
 ;
 ;
GUY S:'$D(DTIME) DTIME=300 K DTOUT,DUOUT,DIRUT,DIR
 S D0=DA,D=DIC_DA_",",DL=1 S:$S('$D(S)#2:1,1:'S) S=3 I '$D(DIQS) W !
 E  S Z=0,A=0 F  S @("Z=$O("_DIQS_"Z))") Q:Z=""  S @(DIQS_"Z)=""""")
 E  S Z=-1
 I $D(DX(0))[0 S DX(0)="Q" I $D(IOST)#2,IOST?1"C".E S DX(0)="S S=S+1 I S>22 N X,Y S DIR(0)=""E"" D ^DIR K DIR W ! S S=$S($D(DIRUT):0,1:1)"
1 I $D(DIQS) S Z=0,A=0 F  S @("Z=$O("_DIQS_"Z))") S:Z="" Z=-1 S A=$O(^DD(DD,"B",Z,0)) S:A="" A=-1 Q:Z<0  I $D(^DD(DD,A,0)) S C=$P(^(0),U,2) I C["C" D COM S @(DIQS_"Z)=X")
 I N<0,$D(^DD(DD,.001,0)) S W=.001,A=-1,Y=@("D"_(DL\2)) G W
 I $G(DIQ(0))["R",N<0,(DL\2)=0 S W=.001,A=-1,O="NUMBER",Y=D0 G W2
N S @("N=$O("_D_"N))") S:N="" N=-1 I DL=1,@E D LF D:$D(DIQ(0)) ^DIQ1:DIQ(0)["C" G Q
 I $D(^(N))#2 S Z=^(N),A=-1 G NS
 I N<0 S DL=DL-1 G B
 I DL#2 S Z=$O(^DD(DD,"GL",N,0,0)) S:Z="" Z=-1 G N:Z<0 S O=0,X=+$P(^DD(DD,Z,0),"^",2) X:$D(DICS) DICS E  G N
 E  G N:N'>0 S X=DD,O=-1,@("D"_(DL\2)_"=N") D LF Q:'S  I $D(DSC(X)) X DSC(X) E  G N
 S DD(DL)=DD,D(DL)=D,N(DL)=N,DL=DL+1 S:+N'=N N=""""_N_"""" S D=D_N_",",N=O,DD=X G 1:DL#2,N
 ;
B I $D(DIQ(0)),DIQ(0)["C",'(DL#2) D ^DIQ1
 S N=N(DL),D=D(DL),DD=DD(DL) D LF Q:'S  G N
 ;
DIQS S @(DIQS_"O)=Y")
NS S A=$O(^DD(DD,"GL",N,A)) S:A="" A=-1 G N:A<0
 S W=$O(^(A,0)) S:W="" W=-1 I A S Y=$P(Z,"^",A) G W:Y]"",NS
 S Y=$E(Z,+$E(A,2,9),$P(A,",",2)) G NS:Y?." "
W S O=$P(^DD(DD,W,0),"^"),C=$P(^(0),"^",2) I $D(DICS) X DICS E  G NS
 I C["W",'$D(DIQS) D DIQ^DIWW G:$D(DN) Q:'DN S DL=DL-2 G B
 D Y I $D(DIQS) G @("DIQS:$D("_DIQS_"O))"),NS:'$D(^(W)) S O=W G DIQS
W2 I $X'<40!($L(O)+$L(Y)>38) S O=$E(O,1,253-$L(Y))
 S O=O_": "_Y I  D LF Q:'S
 W:$X ?40 W:W'?1"."1.2"0"1"1" ?2 W O G NS
 ;
Y I C["O",$D(^(2)) X ^(2) Q  ;NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
S I C["S" S C=";"_$P(^(0),U,3),%=$F(C,";"_Y_":") S:% Y=$P($E(C,%,999),";",1) Q
 I C["P",$D(@("^"_$P(^(0),U,3)_"0)")) S C=$P(^(0),U,2) Q:'$D(^(+Y,0))  S Y=$P(^(0),U) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
 I C["V",+Y,$D(@("^"_$P(Y,";",2)_"0)")) S C=$P(^(0),U,2) Q:'$D(^(+Y,0))  S Y=$P(^(0),U) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
 Q:C'["D"  Q:'Y
D ;S %=$E(Y,4,5)*3,Y=$S(%:$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" ",1:"")_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":"@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)_$S($E(Y,13,14):":"_$E(Y_0,13,14),1:""),1:"") Q
 S Y=$$FMTE^DILIBF(Y,"1U") Q
 ;
DT D D:Y W Y Q
H G H^DIO2
 ;
LF I '$D(DIQS),$X W ! X DX(0)
 Q
EN1 S DRX=DR
EN2 S DR=$P(DRX,";",1),DRX=$P(DRX,";",2,999) D EN W ! G EN2:DRX]""&S
 K DRX Q
EN ;
 S S=0 S:$D(DICSS) DICS=DICSS
 I '$D(IOST)!'$D(IOSL)!'$D(IOM) S IOP="HOME" D ^%ZIS Q:POP
 G Q:'$D(@(DIC_"0)")) S U="^",DD=+$P(^(0),U,2),DK=DD
 I '$D(DR) S N=-1,O=""
 E  S N=$P(DR,":"),N=$S(0[N:-1,+N=N:N-.000001,1:$E(N,1,$L(N)-1)_$C($A(N,$L(N))-1)),O=$P(DR,":",DR[":"+1) G EN1:DR[";"
 S E="N<0" I O]"" S E=E_"!(N]"""_$S(+O=O:"?"")!(N>"_O_")",1:O_""")")
 D GUY S DA=D0 I $D(DIQ(0)),DIQ(0)["A" D AUD^DII
Q K C,O,W,N,E,Z,D,DD,IOP Q
 ;
COM X $P(^(0),U,5,99) S C=$P($P(C,"J",2),",",2) I C?1N.E,X S X=$J(X,0,C)

DIQ1
DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;10/26/94  15:36
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 S DIDQ=DD S:'$D(DICMX) DICMX="W !,O,"": "",X" N DD,D
A F DIQX=0:0 S DIQX=$O(^DD(DIDQ,DIQX)) Q:DIQX'>0  I $D(^(DIQX,0))#2 S Z=^(0),C=$P(Z,U,2),O=$P(Z,U)_" (c)" I C["C" X $P(Z,U,5,99) I X]"" S Y=X D W Q:'S
 K DIDQ,DIQX,Z,DICMX Q
W I C["O",$D(^(2)) X ^(2)
 I C["D" S %=$E(Y,4,5)*3,Y=$S(%:$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" ",1:"")_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":"  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
 I $X>40!($L(O)+$L(Y)>36) S O=$E(O,1,253-$L(Y))
 S O=O_": "_Y I  D LF^DIQ Q:'S
 W:$X ?40 W O Q
 Q
EN ;
 Q:'$D(DIC)!($D(DA)[0)!($D(DR)[0)  S DIL=0,(DA(0),D0)=DA,DIQ0=""
 I $D(DIQ)#2 G Q:DIQ["^"!($E(DIQ,1,2)="DI") S:DIQ'["(" DIQ=DIQ_"("
 S:'$D(DIQ(0)) DIQ(0)="",DIQ0="DIQ(0),"
 I $D(DIQ)[0 S DIQ="^UTILITY(""DIQ1"",$J,",DIQ0="DIQ,"
 S DIQ0=DIQ0_"DIQ0"
 I DIC S DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"") G:DIC="" Q
L G Q:'$D(@(DIC_"0)")) S DI=+$P(^(0),U,2) G Q:'$D(^(DA,0))
 N DII F DII=1:1 S DIQ1=$P(DR,";",DII) Q:DIQ1=""  D C:DIQ1[":",F:DIQ1>0
Q Q:DIL  K %,I,J,X,Y,C,DA(0),DRS,DIL,DI,DIQ1,@DIQ0
 Q
 ;
C S DIQ2=$P(DIQ1,":",2)
 F DIQ1=DIQ1:0 D F S DIQ1=$O(^DD(DI,DIQ1)) I DIQ1'>0!(DIQ1'<DIQ2) S:DIQ1'=DIQ2 DIQ1=0 Q
 Q
F Q:'$D(^DD(DI,DIQ1,0))
 S Y=^(0),C=$P(Y,U,4),X=$P(C,";",2),C=$P(C,";"),J=$P(Y,U,2) G P:J["C"
 I +C'=C S C=""""_C_""""
 I X=0,$D(^DD(+J,.01,0)) G WD:$P(^(0),U,2)["W",S
 S C=$G(@(DIC_DA_","_C_")")),Y=$S(X["E":$E(C,+$P(X,"E",2),+$P(X,",",2)),1:$P(C,U,X))
 I DIQ(0)["I",(DIQ(0)["N"&(Y]"")!(DIQ(0)'["N")) S @(DIQ_"DI,DA,DIQ1,""I"")")=Y
P Q:DIQ(0)'["E"&(DIQ(0)["I")
 I J["C" X $P(Y,U,5,999) K Y S Y=X D:J["D" D^DIQ
 I J'["C" S C=$P(^DD(DI,DIQ1,0),U,2) D:Y]"" Y^DIQ
 Q:Y=""&(DIQ(0)["N")
 S @(DIQ_"DI,DA,DIQ1"_$S(DIQ(0)'["E":"",1:",""E""")_")")=Y
 Q
WD F X=0:0 S X=$O(@(DIC_"DA,"_C_",X)")) Q:X'>0  S @(DIQ_"DI,DA,DIQ1,X)")=^(X,0)
 Q
S ;
 Q:'$D(DR(+J))  Q:'$D(DA(+J))  N DIQ1,I,DI S DIL=DIL+1
 S DRS(DIL)=DR,DIC(DIL)=DIC,DR=DR(+J),DA(DIL)=DA
 S DI=+J,DIC=DIC_DA_","_C_",",DA=DA(+J),@("D"_DIL)=DA
 D L S DR=DRS(DIL),DA=DA(DIL),DIC=DIC(DIL)
 K DRS(DIL),DIC(DIL),DA(DIL),@("D"_DIL)
 S DIL=DIL-1 Q

DIQG
DIQG ;SFISC/DCL-DATA RETRIEVAL PRIMITIVE ;3/5/96  13:48
 ;;21.0;VA FileMan;**22**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ; file,rec,fld,parm,targetarray,errarray,int
DDENTRY I $G(U)'="^" N U S U="^"
 N DIQGDD,DIQGWPB,DIQGWPO S DIQGPARM=$G(DIQGPARM),DIQGIPAR=$G(DIQGIPAR),DIQGDD=DIQGPARM["D",DIQGWPB=DIQGPARM["B"
 S DIQGWPO=1
 ;I DIQGIPAR'["A" K DIERR,^TMP("DIERR",$J)
 N DIQGEY S DIQGEY("FILE")=$G(DIQGR),DIQGEY("RECORD")=$G(DA),DIQGEY("FIELD")=$G(DR)
 I '$D(DIQGR) N X S X(1)="FILE" Q $$F(.X,1)
 I 'DIQGR,'DIQGIPAR N X S X(1)="FILE" Q $$F(.X,12)
 I '$D(DA) N X S X(1)="RECORD" Q $$F(.X,2)
 D:$G(DA)["," IEN(DA,.DA)
 I '$D(DR) N X S X(1)="FIELD" Q $$F(.X,10)
 I 'DIQGIPAR,'DIQGDD Q:$$N9^DIQGU(DIQGR,.DA) $$F(.DIQGEY,16) I '$D(^DD(DIQGR)) N X S X(1)="FILE" Q $$F(.X,18)
 S DIQGETA=$G(DIQGETA) I DIQGETA["("&(DIQGETA'[")") N X S X(1)="TARGET ARRAY" Q $$F(.X,14)
 S:DIQGR DIQGR=$S(DIQGDD:$$DDROOT(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE and/or IEN" Q $$F(.X,4)
 N DIQGSI S DIQGSI=$$CREF(DIQGR)
 Q:'$D(@DIQGSI@(DA)) $$F(.DIQGEY,19)
 I $D(DT)#2-1 N DT S DT=$$DT^DIQGU($H)
 I DR[":" S DIQGEY(1)=$P(DR,":") N X S X=$$GET(DIQGR,DA,$P(DR,":"),"I","","","1A") Q:X'>0 $$F(.DIQGEY,9) Q $$GET("^"_$P(^(0),"^",3),X,$P(DR,":",2,99),DIQGPARM,"","","1A")
 N DIQGPI,DIQGZN S DIQGPI=DIQGPARM["I",DIQGZN=DIQGPARM["Z"
 I DR']"" N X S X(1)="FIELD" Q $$F(.X,5)
 N %,%H,%T,I,J,N,X
 S X=0,N="D0" F  S X=$O(DA(X)) Q:X'>0  S I=X,N=N_",D"_X
 N @N
 S @("D"_+$G(I)_"=DA") I $G(I) F J=I-1:-1:0 S @("D"_J_"=DA(I-J)")
 N C,P,Y,DIQGDN,DIQGD4,DIQGDRN
 S (X,Y)="",DIQGDRN=DR
 S:$D(@DIQGSI@(0)) DIQGDN="^DD("_+$P(^(0),"^",2)_")" I '$D(DIQGDN) N X S X("FILE")=DIQGSI Q $$F(.X,6)
 I DR'?.N,$D(@DIQGDN@("B",DR)) S DIQGDRN=$O(^(DR,"")) I $O(^(DIQGDRN)) N X S X("FILE")=DIQGDN,X(1)=DR Q $$F(.X,15)
 I DIQGDD,DIQGDRN'>0 D  I $E(DIQGDRN,1,6)="$$$ NO" N X S X(1)="ATTRIBUTE" Q $$F(.X,17)
 .S DIQGDRN=$$DDN^DIQGU0(DR) Q:$E(DIQGDRN,1,6)="$$$ NO"
 .S DIQGDN="^DD("_$P(DIQGDRN,"^")_")",DIQGDRN=$P(DIQGDRN,"^",2)
 I DIQGDRN>0,$D(@DIQGDN@(DIQGDRN,0)) S DIQGD4=$P(^(0),"^",4),C=$P(^(0),"^",2),P=$P(DIQGD4,";") G:$P(DIQGD4,";",2)'>0 DIQ S Y=$P($G(@DIQGSI@(DA,P)),"^",$P(DIQGD4,";",2)) G DIQ
 Q $$F(.DIQGEY,7)
DIQ I DIQGDRN=.001 S Y=DA
 I C G BMW
 I C["Cm" N X S X(1)="MULTILINE COMPUTED" Q $$F(.X,3)
 I C["C",DIQGPI Q ""
 I C["C",DIQGDN="^DD(1.005)",DIQGDRN=1 S X=@DIQGSI@(DA,0)
 I C["C",$D(@DIQGDN@(DIQGDRN,0)) N DCC,DFF,DIQGH S DIQGH=$G(DIERR),DCC=DIQGR,DFF=+$P(DCC,"(",2) X $P(^(0),"^",5,999) D:DIQGH'=$G(DIERR)  Q $S(C["D":$$FMTE^DILIBF($G(X),"1U"),1:$G(X))
 .N X
 .D BLD^DIALOG(120,"FIELD")
 .Q
 I 'DIQGPI&(C["O"!(C["S")!(C["P")!(C["V")!(C["D"))&($D(@DIQGDN@(DIQGDRN,0))) S C=$P(^(0),"^",2) Q $$EXTERNAL^DIDU(+$P(DIQGDN,"(",2),DIQGDRN,"",Y)
 I C["K" Q $E($G(@DIQGSI@(DA,P)),$E($P($P(DIQGD4,";",2),","),2,99),$P($P(DIQGD4,";",2),",",2))
 I C["C" Q $G(Y)
 I $E($P(DIQGD4,";",2))="E" Q $E($G(@DIQGSI@(DA,P)),$E($P($P(DIQGD4,";",2),","),2,99),$P($P(DIQGD4,";",2),",",2))
 Q $G(Y)
BMW I C,$P(^DD(+C,.01,0),"^",2)["W" Q:DIQGWPB "$CREF$"_DIQGR_DA_","_$$Q^DIQGU(P)_")" D  G:X="" FE Q:DIQGWPO $NA(@DIQGETA) Q:DIQGIPAR "$WP$" Q ""
 .I DIQGETA']"" K X S X(1)="TARGET ARRAY" D BLD^DIALOG(202,.X) S X="" Q
 .S X=DIQGR_DA_","_$$Q^DIQGU(P)_")"
 .I '$P($G(@X@(0)),"^",3) S X="" Q
 .I DIQGZN M @DIQGETA=@X K @DIQGETA@(0) Q
 .S Y=0 F  S Y=$O(@X@(Y)) Q:Y'>0  I $D(^(Y,0)) S @DIQGETA@(Y)=^(0)
 .Q
 I C,$P(^DD(+C,.01,0),"^",2)["M" Q $$F(.DIQGEY,11)
 I DIQGPI!(DIQGDD) Q $G(Y)
 Q $$F(.DIQGEY,8)
CREF(X) N L,X1,X2,X3 S X1=$P(X,"("),X2=$P(X,"(",2,99),L=$L(X2),X3=$TR($E(X2,L),",)"),X2=$E(X2,1,(L-1))_X3 Q X1_$S(X2]"":"("_X2_")",1:"")
WP(DIQGSA,DIQGTA,DIQGZN,DIQGP) N DIQG S DIQG=0 F  S DIQG=$O(@DIQGSA@(DIQG)) Q:DIQG'>0  I $D(^(DIQG,0)) S @$S(DIQGZN:"@DIQGTA@(DIQG,0)",1:"@DIQGTA@(DIQG)")=^(0)
 Q:DIQGP "$WP$" Q ""
DY(Y) Q $$FMTE^DILIBF(Y,"1U")
IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)=""  S DA(I-1)=$P(IEN,",",I)
 Q
DDROOT(X) Q:'$D(^DD(X)) "" Q "^DD("_X_","
 ;
F(DIQGEY,X) D BLD^DIALOG($P($T(TXT+X),";",4),.DIQGEY)
FE I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
 Q ""
TXT ;;
 ;;file root/ref invalid;202;1
 ;;record invalid;202;2
 ;;multiline computed;520;3
 ;;file ref invalid;202;4
 ;;field name/number invalid;202;5
 ;;DD ref for file/field invalid;401;6
 ;;unable to find field name;200;7
 ;;unable to identify type of data in DD;510;8
 ;;unable to resolve extended ref;501;9
 ;;field ref missing;202;10
 ;;multiple field - invalid parameters;309;11
 ;;file number not passed or invalid;202;12
 ;;;;13
 ;;invalid target array;202;14
 ;;ambiguous field name;505;15
 ;;record unavailable;602;16
 ;;invalid attribute;202;17
 ;;file not found;202;18
 ;;record entry does not exist;601;19
 ;;;;20

DIQGDD
DIQGDD ;SFISC/DCL-DATA DICTIONARY ATTRIBUTE RETRIEVER;01:52 PM  12 Sep 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;
EN3 I $G(U)'="^" N U S U="^"
 I $G(DIQGIPAR)'["A" K DIERR,^TMP("DIERR",$J)
 I $G(DIQGR)'>0 N X S X(1)="FILE" Q $$F^DIQG(.X,1)
 I $G(DA)']"" S DA=DIQGR,DIQGR=1 I '$D(^DIC(DA,0)) S X(1)="FILE" Q $$F^DIQG(.X,1)
 S:DIQGR>1 DIQGPARM=$G(DIQGPARM)_"D"
 I DA'?.N,$D(^DD(DIQGR,"B",DA)) S DA=$O(^(DA,"")) I $O(^(DA)) D 200 Q ""
 I DA'>0 D 200 Q ""
 I '$$VLDATRBT(DIQGR=1,$G(DR)) D 202("ATTRIBUTE") Q ""
 I DR="FIELD LENGTH" Q $$FL^DIQGDDU(DIQGR,DA)
 I DR="REQUIRED IDENTIFIERS" G RI^DIQGDDU
 G DDENTRY^DIQG
 ;
FILE(DIQGR,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN2 N DA
 S DA=""
 I '$G(DIQGR),$G(DIQGR)]"",$D(^DIC("B",DIQGR)) S DIQGR=$O(^(DIQGR,""))
 G EN1
 ;
FIELD(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN1 N DIQGERR,DIQGEY,DIQGSAL,DIQGFNUL,DIQGSALX,DIQGTAXX
 S DIQGEY(1)=$G(DIQGR)
 I $G(U)'="^" N U S U="^"
 I $G(DIQGIPAR)'["A" K DIERR,^TMP("DIERR",$J)
 I $G(DIQGR)'>0 D 202("FILE") Q
 I '$D(^DD(DIQGR,0)) D 202("FILE") Q
 I $G(DA)']"" S DA=DIQGR,DIQGR=1 I '$D(^DIC(DA,0)) D 202("FILE") Q
 I $G(DIQGTA)']"" D 202("TARGET ARRAY") Q
 S DIQGPARM=$G(DIQGPARM)_$S(DIQGR>1:"D",1:""),DIQGFNUL=DIQGPARM["N"
 I DA'?.N,$D(^DD(DIQGR,"B",DA)) S DA=$O(^(DA,"")) I $O(^(DA)) N X S X(1)=DA,X("FILE")=DIQGR D BLD^DIALOG(505,.X),FE Q
 I DA'>0 S DIQGEY(3)=DA D 200 Q
 I DIQGR>1,'$D(^DD(DIQGR,DA,0)) S DIQGEY(3)=DA D 200 Q
 D BLDSAL(DIQGR=1,.DR,.DIQGSAL)
 I '$D(DIQGSAL),'$D(DIERR) D 200 Q
 I '$D(DIQGSAL) Q
 S DIQGSAL="" F  S DIQGSAL=$O(DIQGSAL(DIQGSAL)) Q:DIQGSAL=""  D
 .I DIQGR=1,DIQGSAL="REQUIRED IDENTIFIERS" D  Q
 ..N X
 ..S X=$$RIF^DIQGDDU(DA,DIQGSAL,DIQGTA)
 ..S:X]"" @DIQGTA@(DIQGSAL)=X
 ..Q
 .S DIQGTAXX=$S('$D(DIQGSAL(DIQGSAL,"#(word-processing)")):DIQGTA,1:$$OREF(DIQGTA)_$$Q(DIQGSAL)_")")
 .I DIQGR>1,DIQGSAL="FIELD LENGTH" S DIQGSALX=$$FL^DIQGDDU(DIQGR,DA) G SET
 .S DIQGSALX=$$GET^DIQG($S(DIQGR>1:"^DD("_DIQGR_",",1:"^DIC("),DA,DIQGSAL(DIQGSAL),DIQGPARM,DIQGTAXX,"","1A")
 .;I $D(DIQGSAL(DIQGSAL,"#(word-processing)")) Q
SET .I DIQGSALX]"" S @DIQGTA@(DIQGSAL)=DIQGSALX Q
 .Q:DIQGFNUL
 .S @DIQGTA@(DIQGSAL)=DIQGSALX
 .Q
 Q
 ;
BLDSAL(DIQGTYPE,DIQGDR,DIQGVALA) ;DIQGTYPE=1 for FILE and 0 for FIELD, DIQGDR=string/array, DIQGVALA=valid attribute list array
 ; * If DIQGDR is an array pass by reference *
 I $G(DIQGDR)="*" D LIST^DIQGDDT($S(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGVALA,"",3) Q
 N DIQGER,DIQGI,DIQGX,DIQGY D LIST^DIQGDDT($S(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGX,"",3)
 I $G(DIQGDR)]"" F DIQGI=1:1 S DIQGY=$P(DIQGDR,";",DIQGI) Q:DIQGY=""  D
 .I '$D(DIQGX(DIQGY)) S DIQGER(4)=DIQGY D 200 Q
 .S DIQGVALA(DIQGY)=DIQGX(DIQGY) S:$D(DIQGX(DIQGY,"#(word-processing)")) DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
 Q:$D(DIQGVALA)
 S DIQGY="" F  S DIQGY=$O(DIQGDR(DIQGY)) Q:DIQGY=""  D
 .I '$D(DIQGX(DIQGY)) S DIQGER(4)=DIQGY D 200 Q
 .S DIQGVALA(DIQGY)=DIQGX(DIQGY) S:$D(DIQGX(DIQGY,"#(word-processing)")) DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
 .Q
 Q
 ;
XDR(DIQGR,DR,DIQGERR) ;DIQGR DD FILE NUMBER EITHER 1 OR 0
 ;DR IS DR STRING TO CONVERT TO NUMERIC DR STRING
 S DIQGR=+$G(DIQGR),DR=$G(DR)
 N I,X,XDR D LIST^DIQGDDT($S(DIQGR=1:"FILETXT",1:"FIELDTXT"),.X,4,3)
 I $G(DR)]"" S (X,XDR)="" F I=1:1 S X=$P(DR,";",I) Q:X=""  D
 .I '$D(X(X)) S DIQGERR(X)="" Q
 .S XDR=XDR_X(X)_";" Q
 I $D(DR)>1 S (X,XDR)="" F  S X=$O(DR(X)) Q:X=""  D:'$D(X(X))  S:X]"" XDR=XDR_X(X)_";"
 .I '$D(X(X)) S DIQGERR(X)="" Q
 .S XDR=XDR_X(X)_";" Q
 Q XDR
 ;
VLDATRBT(TYPE,ATRIB) ;EXTRINSIC FUNCTION $$TEST IF VALID ATTRIBUTE
 ;TYPE 0 OR 1 - FIELD=0, FILE=1 (^DD(0) OR ^DD(1))
 ;ATRIB=ATTRIBUTE BEING REQUESTED
 Q:ATRIB']"" 0
 N X D LIST^DIQGDDT($S(TYPE=1:"FILETXT",1:"FIELDTXT"),.X)
 Q $D(X(ATRIB))#2
DR(TYPE) ;TYPE=1,FILE OR 0,FIELD AND RETURNS DR STRING FOR ALL ATTRIBUTES IN INTERNAL FORM (ATTRIBUTE FIELD NUMBERS 3RD ;-PIECE
 S TYPE=+$G(TYPE)
 N X,Y
 D LIST^DIQGDDT($S(TYPE=1:"FILETXT",1:"FIELDTXT"),.X,3)
 S (X,Y)=.01 F  S Y=$O(X(Y)) Q:Y'>0  S X=X_";"_Y
 Q X
 ;
FILELST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FILE ATTRIBUTES * *
EN4 N EQL,TP,TYPE,DIQGDFLG
 S TYPE="FILETXT",DIQGDFLG="L"
 G ENLST^DIQGDDT
 ;
FIELDLST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FIELD ATTRIBUTES * *
EN5 N EQL,TP,TYPE,DIQGDFLG
 S TYPE="FIELDTXT",DIQGDFLG="L"
 G ENLST^DIQGDDT
 ;
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
200 D BLD^DIALOG(200),FE Q
202(E) N X S X(1)=E
 D BLD^DIALOG(202,.X),FE
 Q
FE I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
 Q

DIQGDD0
DIQGDD0 ;DCL/SFISC-NODE PIECE LOOKUP FOR DD;09:26 AM  5 Jan 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
NPS(DIQGDDN,DIQGNP) ;(CLOSEREFERENCE,PIECE)
 ;NODE PIECE SEARCH - DIQGDDN IS DD NUMBER - DIQGNP IS PIECE
 ; * * RETURNS FIELD NUMBER * *
 Q:$G(DIQGDDN)'>0 "" Q:$G(DIQGNP)="" ""
 N DIQGDDRT,DIQGDDRO,DIQGDDRN,DIQGFLD
 S DIQGDDRT="^DD("_DIQGDDN_")"
 S DIQGDDRO=0,DIQGFLD=""
 F  S DIQGDDRO=$O(@DIQGDDRT@(DIQGDDRO)) Q:DIQGDDRO'>0  D  Q:DIQGFLD
 .Q:'$D(@DIQGDDRT@(DIQGDDRO,0))  S DIQGDDRN=$P(^(0),"^",4)
 .I DIQGNP=DIQGDDRN S DIQGFLD=DIQGDDRO Q
 .I $P(DIQGDDRN,";")'?.N S $P(DIQGDDRN,";")=$$Q($P(DIQGDDRN,";")) I DIQGNP=DIQGDDRN S DIQGFLD=DIQGDDRO Q
 .I $P(DIQGDDRN,";")=$P(DIQGNP,";"),$E($P(DIQGDDRN,";",2))="E" S DIQGFLD=DIQGDDRO Q
 .Q
 Q DIQGFLD
 ;
Q(%Z) ;(PLACE QUOATES AROUND %Z)
 S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
 ;
FN(DIQGROOT) ;(CLOSEDREFERENCE)
 ; * * RETURNS FILE NUMBER * *
 ;CONVERT ROOT TO FILE NUMBER
 Q:$L($G(DIQGROOT),",")'>1 ""
 Q:$E(DIQGROOT,$L(DIQGROOT))'=")" ""
 N I,L,T,X,Y
 S X=DIQGROOT,L=$L(X),T=""
 F I=L:-1 S Y=$E(X,I) S:Y=","!(Y="(") T=T=0 Q:Y=""  I T,((Y=",")!(Y="(")) Q
 I I,$D(@($E(X,1,I)_"0)")) Q +$P(^(0),"^",2)
 Q ""
 ;
NP(ROOT,PIECE) ;CONVERT ROOT AND PIECE TO NODE;PIECE
 ; * * RETURNS 'NODE;PIECE' * *
 Q:$G(ROOT)="" "" Q:$G(PIECE)="" ""
 Q $P($P(ROOT,",",$L(ROOT,",")),")")_";"_PIECE
 ;
PIECE(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,ATTRIBUTE,FLAG,TARGETARRAY,ERRORARRAY,INTERNAL
EN6 ;PROCEDURE CALL AND  * * RETURN RESULTS IN TARGET ARRAY * *
 I $G(U)'="^" N U S U="^"
 N DIQGNP S DIQGR=$G(DIQGR),DA=$G(DA)
 S DIQGNP=$$NP(DIQGR,DA) I DIQGNP="" G 200
 S DIQGR=$$FN(DIQGR) I DIQGR="" G 200
 S DA=$$NPS(DIQGR,DIQGNP) I DA'>0 G 200
 G EN1^DIQGDD
 ;
200 D BLD^DIALOG(200)
 I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
 Q

DIQGDDT
DIQGDDT ;SFISC/DCL-DATA DICTIONARY ATTRIBUTE TEXT ;8/15/96  13:29
 ;;21.0;VA FileMan;**25**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LIST(TYPE,DIDARRAY,TP,EQL) ;DO CALL
 ;TYPE="FILETXT" OR "FIELDTXT"
 ;DIDARRAY=TARGET ARRAY - IS LOCAL ARRAY PASSED BY REFERENCE WHICH WILL BE SEEDED WITH FILE OR FIELD ATTRIBUTES
 ;TP=TEXT PIECE USING ; AS DELIMITER
 ;EQL=EQUAL TO - NULL IS DEFAUL OR PIECE OF TXT
ENLST S:$G(TP)'>0 TP=4 S:$G(EQL)'>0 EQL=99
 N DIQGI,DIQGX,DIQGY F DIQGI=1:1 S DIQGX=$T(@TYPE+DIQGI),DIQGY=$P(DIQGX,";",TP) Q:DIQGY=""  D
 .S DIDARRAY(DIQGY)=$P(DIQGX,";",EQL)
 .S:$P(DIQGX,";",5)]"" DIDARRAY(DIQGY,"#(word-processing)")=$S($G(DIQGDFLG)["L":"",1:$P(DIQGX,";",5))
 .I $P(DIQGX,";",6)]"" D
 ..N TYPE
 ..S TYPE=$P(DIQGX,";",7)
 ..N DIQGI,DIQGX,DIQGYS
 ..F DIQGI=1:1 S DIQGX=$T(@TYPE+DIQGI) Q:$P(DIQGX,";",4)=""  D
 ...S DIQGYS=$P(DIQGX,";",4),DIDARRAY(DIQGY,"#",DIQGYS)=""
 ...Q
 .Q
 ;DIQGI,DIQGY ARE SCRATCH VARIABLES USED TO BUILD ARRAY
 ;DIQGI INDEXES TEXT AND DIQGY CONTAINS THE ATTRIBUTE NAME
 Q
DD N %,%ZISOS,A,D0,D1,D2,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y,DIQGF,DIQGFN
 S DIC=1,DIC(0)="AEMQ" D ^DIC Q:Y'>0  ;Select file
 S DIC="^DD("_+Y_",",DIQGFN=+Y
 D F(DIQGFN,.DIQGF)
 D ^%ZIS Q:POP  U IO
 S DIC="^DIC(",DA=DIQGFN
 D EN^DIQ
 S X=""
 F  S X=$O(^DIC(DIQGFN,0,X)) Q:X=""  W !,X,"=",^(X)
 S DIQGF="" F  S DIQGF=$O(DIQGF(DIQGFN,DIQGF)) Q:DIQGF=""  D
 .W !,$$L("=",IOM),!,"DD NUMBER: ",DIQGF,!
 .S DA="" F  S DA=$O(DIQGF(DIQGFN,DIQGF,DA)) Q:DA=""  D
 ..W !,$$L("-",IOM),!
 ..S DIC="^DD("_DIQGF_"," D EN^DIQ
 ..Q
 .Q
 W !!,"End of Report",!!
 D ^%ZISC
 Q
 ;
L(X,RM) Q $TR($J("",RM)," ",X)
 ;
F(DIQGDICN,DIQGFSTA,DIQGSEL,DIQGDEL) ;
 ;  DIQGDICN file number
 ;  DIQGFSTA Field Selected Target Array(can be passed by reference or
 ;                                       as a reference)
 ;  DIQGSEL Selection Marker(optional)
 ;  DIQGDEL Deselection Marker (optional)
 N %,%Y,DA,DDC,DIC,DIQGDWN,DIQGTGA,X,Y
 I $D(@("^DIC("_DIQGDICN_",0)")) W !!?4,"'",$P(^(0),"^"),"' FILE",!
 S:'$D(DIQGSEL) DIQGSEL="+" S:'$D(DIQGDEL) DIQGDEL="-"
 S DIC="^DD("_DIQGDICN_",",DIC(0)="AEMQ",X=$E($G(DIQGFSTA)),DIQGTGA=(X="^"!(X=".")) S:X="." DIQGFSTA=$E(DIQGFSTA,2,99)
M S DIC("W")="W:$P(^(0),U,2) $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":""  (word-processing)"",1:""  (multiple)"") W:$D("_$S(DIQGTGA:"@DIQGFSTA@(DIQGDICN,+$E(DIC,5,99),+Y)",1:"DIQGFSTA(DIQGDICN,+$E(DIC,5,99),+Y)")_") DIQGSEL"
 D ^DIC I Y'>0,$D(@(DIC_"0,""UP"")")) S DIC="^DD("_+^("UP")_"," G M ;Select field/back out of multiples
 S DIQGDWN="" I Y>0,$P(@(DIC_+Y_",0)"),U,2) S DIQGDWN=+$P(^(0),U,2) I $P(^DD(+$P(^(0),U,2),.01,0),U,2)'["W" D T(DIQGDWN) S DIC="^DD("_DIQGDWN_"," G M
 I Y>0,DIQGDWN>0 D T(DIQGDWN) G M
 I Y>0 D T() G M
 Q
T(DWN) ;
 D @$S(DIQGTGA:"TAR(+$E(DIC,5,99),+Y,$G(DWN))",1:"TBR(+$E(DIC,5,99),+Y,$G(DWN))")
 Q
TAR(DDFN,FLD,DWNFN) ;Target array is in DIQGFSTA As a global/local Reference
 I DWNFN S @DIQGFSTA@(DIQGDICN,DWNFN)=DDFN_"^"_FLD
 I '$D(@DIQGFSTA@(DIQGDICN,DDFN,FLD)) S @DIQGFSTA@(DIQGDICN,DDFN,FLD)=$S(DWNFN:DWNFN,1:"") Q
 I DWNFN,$D(@DIQGFSTA@(DIQGDICN,DWNFN))>9 Q
 N X S X=$G(@DIQGFSTA@(DIQGDICN,DDFN,FLD)) I X K @DIQGFSTA@(DIQGDICN,$P(X,"^"))
 K @DIQGFSTA@(DIQGDICN,DDFN,FLD) W DIQGDEL Q
 Q
TBR(DDFN,FLD,DWNFN) ;Target array DIQGFSTA is a local array passed By Reference
 I DWNFN S DIQGFSTA(DIQGDICN,DWNFN)=DDFN_"^"_FLD
 I '$D(DIQGFSTA(DIQGDICN,DDFN,FLD)) S DIQGFSTA(DIQGDICN,DDFN,FLD)=$S(DWNFN:DWNFN,1:"") Q
 I DWNFN,$D(DIQGFSTA(DIQGDICN,DWNFN))>9 Q
 N X S X=$G(DIQGFSTA(DIQGDICN,DDFN,FLD)) I X K DIQGFSTA(DIQGDICN,$P(X,"^"))
 K DIQGFSTA(DIQGDICN,DDFN,FLD) W DIQGDEL Q
 Q
 ;
 ;ATRBUTE FLD #;ATRBUTE NAME;1=WORD PROCESSING
FILETXT ;
 ;;.01;NAME;
 ;;1;GLOBAL NAME;
 ;;1.1;ENTRIES;
 ;;4;DESCRIPTION;1
 ;;20;DEVELOPER;
 ;;21;DATE;
 ;;31;DD ACCESS;
 ;;32;RD ACCESS;
 ;;33;WR ACCESS;
 ;;34;DEL ACCESS;
 ;;35;LAYGO ACCESS;
 ;;36;AUDIT ACCESS;
 ;;50;LOOKUP PROGRAM;
 ;;51;VERSION;
 ;;51.1;DISTRIBUTION PACKAGE;
 ;;51.2;PACKAGE REVISION DATA;
 ;;54;ARCHIVE FILE;
 ;;100.6;REQUIRED IDENTIFIERS;;1;RI
 ;;
FIELDTXT ;
 ;;.01;LABEL;
 ;;.1;TITLE;
 ;;.2;SPECIFIER;
 ;;.24;DECIMAL DEFAULT;
 ;;.25;TYPE;
 ;;.26;COMPUTE ALGORITHM;
 ;;.28;MULTIPLE-VALUED;
 ;;.3;POINTER;
 ;;.4;GLOBAL SUBSCRIPT LOCATION;
 ;;.5;INPUT TRANSFORM;
 ;;1.1;AUDIT;
 ;;1.2;AUDIT CONDITION;
 ;;2;OUTPUT TRANSFORM;
 ;;3;HELP-PROMPT;
 ;;4;XECUTABLE HELP;
 ;;8;READ ACCESS;
 ;;8.5;DELETE ACCESS;
 ;;9;WRITE ACCESS;
 ;;9.01;COMPUTED FIELDS USED;
 ;;10;SOURCE;
 ;;21;DESCRIPTION;1
 ;;23;TECHNICAL DESCRIPTION;1
 ;;50;DATE FIELD LAST EDITED;
 ;;200;FIELD LENGTH;
 ;
RI ;REQUIRED IDENTIFIERS
 ;;1;FIELD;
 ;;

DIQGDDU
DIQGDDU ;SFISC/DCL-DATA DICTIONARY UTILITIES ;10:55 AM  1 Aug 1994;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
FL(DIQGFILE,DIQGFLD) ;RETURNS FIELD LENGTH
 ;FILENUMBER,FIELDNUMBER
 ;Short version of DIOS1
 I $G(DIQGFILE)'>0 D ERR202("FILE NUMBER") Q ""
 I $G(DIQGFLD)'>0 D ERR202("FIELD NUMBER") Q ""
 I '$D(^DD(DIQGFILE,DIQGFLD,0)) D ERR1700("DD FOR FILE#"_DIQGFILE_", FIELD#"_DIQGFLD_" DOES NOT EXIST") Q ""
 N DN,W
X S DN=$P(^(0),"^",2),W=+$P(DN,"J",2) G DJ:W I $P(DN,"P",2)!(DN) G X:$D(^DD($S(DN:DN,1:+$P(DN,"P",2)),.01,0)),DJ
 I DN["C",DN'["J" S W=30
 I DN'["F" S W=13 G DJ
 S W=+$P(^(0),"$L(X)>",2) S:'W W=30
DJ Q W
 ;
ERR202(DIQGERR) ;Error processing
 N P S P(1)=DIQGERR
 D BLD^DIALOG(202,.P)
 Q
ERR1700(DIQGERR) ;Error processing
 N P S P(1)=DIQGERR
 D BLD^DIALOG(1700,.P)
 Q
 ;
RIF(DA,DR,DIQGETA) ;FUNCTION CALL FOR RI
RI ;REQUIRED IDENTIFIERS - CALLED BY EN3^DIQGDD
 ;DA=FILENR,DR="REQUIRED IDENTIFIERS",DIQGETA=TARGET_ARRAY
 N DIQGRIA,DIQGRI,DIQGR
 D REQIDS^DICU(DA,"DIQGRIA")
 S DIQGRIA="",DIQGRI=0
 F  S DIQGRIA=$O(DIQGRIA(DR,DIQGRIA)) Q:DIQGRIA=""  D
 .S DIQGRI=DIQGRI+1,@DIQGETA@(DR,DIQGRI,"FIELD")=DIQGRIA
 .Q
 Q $S(DIQGRI:$NA(@DIQGETA@(DR)),1:"")

DIQGQ
DIQGQ ;SFISC/DCL-DATA RETRIEVAL;09:41 AM  19 Jan 1995
 ;;21.0;VA FileMan;**5**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
DDENTRY N DIQGQE S DIQGQE=0
 I $G(U)'="^" N U S U="^"
 ;K DIERR,^TMP("DIERR",$J)
 ;N DIERR
 N DIQGCP,DIQGDD S DIQGPARM=$G(DIQGPARM),DIQGIPAR=$G(DIQGIPAR),DIQGDD=DIQGPARM["D",DIQGCP=$S(DIQGDD:"D",1:"") S:DIQGPARM["Z" DIQGCP=DIQGCP_"Z" S:DIQGPARM["F" DIQGCP=DIQGCP_"F"
 N DIQGFE,DIQGFEN S DIQGFE=DIQGPARM["R"
 N DIQGFET S DIQGFET=DIQGPARM["T"
 I '$D(DIQGR) N X S X(1)="FILE" G 202
 N DIQGI1 S DIQGI1=+DIQGIPAR=0
 I DIQGI1,'DIQGR N X S X(1)="FILE" G 202
 D:$G(DA)["," IEN(DA,.DA)
 I DIQGI1,'DIQGDD,$$N9^DIQGU(DIQGR,.DA) D BLD^DIALOG(602) G OUT
 I '$D(DA) N X S X(1)="RECORD" G 202
 I '$D(DR) N X S X(1)="FIELD" G 202
 I DIQGI1,$G(DIQGTA)']"" N X S X(1)="TARGET ARRAY" G 202
 I DIQGI1,("("[$G(DIQGTA)&(")"'[$G(DIQGTA))) N X S X(1)="TARGET ARRAY" G 202
 S:DIQGR DIQGR=$S(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE AND IEN COMBINATION" G 202
 N DIQGMDD,DIQGE,DIQGI,DIQGXXE,DIQGXXI,DIQGSI,DIQGXAF,DIQGXPRI,DIQGXPRE,DIQGXPRN,DIQGXPRF,DIQGXDD,DIQGXDDN,DIQGXPRA,DIQGXTA,DIQGXDA,DIQGXPRS,DIQGPRSE S DIQGPRSE=1
 S DIQGSI=$$CREF(DIQGR),DIQGXAF=0,DIQGXPRI=DIQGPARM["I",DIQGXPRE=DIQGPARM["E",DIQGXPRN=DIQGPARM["N",DIQGXPRF=DIQGPARM["F",DIQGXPRS=DIQGPARM["S" S:DIQGXPRS DIQGXPRE=1,DIQGXPRI=1 S DIQGXPRA=DIQGXPRE!DIQGXPRI
 I '$D(@DIQGSI@(DA)) D BLD^DIALOG(601) G OUT
 S:$D(@DIQGSI@(0)) DIQGXDDN=+$P(^(0),"^",2),DIQGXDD="^DD("_DIQGXDDN_")" I '$D(DIQGXDD) N X S X("FILE")=DIQGR D BLD^DIALOG(401,.X) G OUT
 S:'DIQGXDDN DIQGXDDN=+$P(DIQGR,"(",2)
 I $D(DIQGTA)=1,DIQGTA]"",DIQGTA'>0 S DIQGXAF=1,DIQGXTA=DIQGTA S DIQGXTA=$$CREF(DIQGXTA)
 N DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDT S DIQGXDC=0
 F DIQGXDI=1:1 S DIQGXDF=$P(DR,";",DIQGXDI),DIQGXDN=$P(DIQGXDF,":") Q:DIQGXDF=""  D  I $L(DIQGXDF,":")>1  S DIQGXDT=$P(DIQGXDF,":",2) F  S DIQGXDN=$O(@DIQGXDD@(+DIQGXDN)) Q:DIQGXDN'>0!(DIQGXDN>DIQGXDT)  S DIQGXDC=$P(^(DIQGXDN,0),"^",2) D  ;
 .I DIQGXDC,$P(^DD(+DIQGXDC,.01,0),"^",2)'["W" S:DR="**" DIQGXDN=DIQGXDN_"*" Q:$L(DIQGXDN,"*")'=2
 .I DIQGXDN'?.N,$L(DIQGXDN,"*")=2,$P(DIQGXDN,"*")]"",$D(@DIQGXDD@("B",$P(DIQGXDN,"*"))) S DIQGXDN=$O(^($P(DIQGXDN,"*"),""))_"*"
 .I $L(DIQGXDN,"*")=2,+DIQGXDN>0 S DIQGMDD=+$P($G(@DIQGXDD@(+DIQGXDN,0)),"^",2) I DIQGMDD,$P(^DD(DIQGMDD,.01,0),"^",2)'["W" D  Q
 ..N DIQGMDA,DIQGMGR
 ..D  F  S DIQGMDA=$O(@DIQGMGR@(DIQGMDA)) Q:DIQGMDA'>0  D EN($S('DIQGDD:DIQGMDD,1:$$OREF(DIQGMGR)),.DIQGMDA,"**",DIQGPARM,.DIQGTA,"",$S('DIQGDD:"",1:1))
 ...N I F I=1:1 Q:'$D(DA(I))  S DIQGMDA(I+1)=DA(I)
 ...S DIQGMDA(1)=DA,DIQGMGR=$S('DIQGDD:$$ROOT^DIQGU(DIQGMDD,.DIQGMDA,1),1:DIQGR_DA_","_$$Q($P($P(@DIQGXDD@(+DIQGXDN,0),"^",4),";"))_")"),DIQGMDA=0
 ...Q
 .I DIQGXDN="*"!(DIQGXDN="**") S DIQGXDN=0,DIQGXDF=":999999999" Q
 .S DIQGXDA=$$DA(.DA),DIQGFEN=$S((DIQGFE&(DIQGXDN))!(DIQGFET):$P(@DIQGXDD@(DIQGXDN,0),"^"),1:DIQGXDN) S:DIQGFET DIQGFEN=DIQGXDN_" "_DIQGFEN
 .I DIQGDD N DIQGXDDN S DIQGXDDN="DD"
 .I DIQGXPRI D  Q:DIQGI="$WP$"  G:$G(DIERR) ERR
 ..S DIQGI=$$GET^DIQG(DIQGR,.DA,DIQGXDN,"I"_DIQGCP,$S('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
 ..S DIQGXXI='DIQGXPRN!(DIQGXPRN&(DIQGI]""))
 ..Q
 .I DIQGXPRE!'DIQGXPRA D  Q:DIQGE="$WP$"
 ..S DIQGE=$$GET^DIQG(DIQGR,.DA,DIQGXDN,DIQGCP,$S('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
 ..S DIQGXXE='DIQGXPRN!(DIQGXPRN&(DIQGE]""))
 ..Q
ERR .I $G(DIERR) S $P(DIQGQERR,U)=$P($G(DIQGQERR),U)+DIERR,$P(DIQGQERR,U,2)=$P($G(DIQGQERR),U,2)+$P(DIERR,U,2) K DIERR S DIQGQE=DIQGQE+1 Q
 .S:DIQGXPRS DIQGPRSE=DIQGI'=DIQGE
 .I DIQGXAF,DIQGXPRA D  Q
 ..G:DIQGXPRF XPRF1
 ..I DIQGXPRI,DIQGXXI S @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"I")=DIQGI
 ..I DIQGXPRE,DIQGXXE,DIQGPRSE S @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"E")=DIQGE
 ..Q
XPRF1 ..I DIQGXPRI,DIQGXXI S @DIQGXTA@(DIQGFEN,"I")=DIQGI
 ..I DIQGXPRE,DIQGXXE,DIQGPRSE S @DIQGXTA@(DIQGFEN,"E")=DIQGE
 ..Q
 .I DIQGXAF D  Q
 ..I DIQGXPRF,DIQGXXE S @DIQGXTA@(DIQGFEN)=DIQGE Q
 ..S:DIQGXXE @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN)=DIQGE
 ..Q
 .Q
 Q
CREF(X) N L,X1,X2,X3 S X1=$P(X,"("),X2=$P(X,"(",2,99),L=$L(X2),X3=$TR($E(X2,L),",)"),X2=$E(X2,1,(L-1))_X3 Q X1_$S(X2]"":"("_X2_")",1:"")
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
DA(DA) N X,Y S X="",Y=$G(DA)_"," F  S X=$O(DA(X)) Q:X=""  S Y=Y_DA(X)_","
 Q Y
IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)=""  S DA(I-1)=$P(IEN,",",I)
 Q
Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
DD(X) Q:'$D(^DD(X)) "" Q "^DD("_X_","
202 D BLD^DIALOG(202,.X)
OUT Q

DIQGU
DIQGU ;SFISC/DCL-DATA RETRIEVAL INTERNAL FUNCTIONS;MAR 29, 1995@14:19
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DT(H) N D,M,X,Y
 S X=H>21608+H-.1,Y=X\365.25+141,X=X#365.25\1
 S D=X+306#(Y#4=0+365)#153#61#31+1,M=X-D\29+1
 Q Y_"00"+M_"00"+D
ROOT(DIC,DA,CP,ERR) ;
ENROOT S ERR=$G(ERR)=1
 N DIQGUFN,DIQGUIEN
 S DIQGUFN=$G(DIC),DIQGUIEN=$G(DA)
 I DIC="" D:ERR BLD^DIALOG(200) Q ""
 N RQ
 S RQ=$G(CP)'["Q"
 S CP=$G(CP)'[1
 G:$L($G(DA),",,")>1 ERR
 D:$G(DA)["," DAIEN(DA,.DA)
 I $G(^DIC(DIC,0,"GL"))]"" N DIQGUX S DIQGUX=^("GL") D:ERR  Q:CP DIQGUX Q $$CREF(DIQGUX)
 .Q:$G(DIQGUIEN)'[","
 .N X S X=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN)
 .Q:X
 .S (CP,DIQGUX)=""
 .Q
 N A,A2
 I $D(DA)>9,$G(^DIC(+$$UP(DIC,.A),0,"GL"))]"" S DIC=^("GL"),A=$P($O(A("")),"-",2) I A>0,$D(DA(A))=1,'$O(DA(A)) D  Q:CP DIC Q $$CREF(DIC)
 .S A="" F  S A=$O(A(A)) Q:A'<0  D
 ..I RQ S A2=$P(A(A),"^",2),DIC=DIC_DA($P(A,"-",2))_","_$$Q(A2)_"," Q
 ..S A2=$P(A(A),"^",2),DIC=DIC_DA($P(A,"-",2))_","""_A2_"""," Q
ERR Q:'ERR ""
 S DIQGUIEN=$$IENS^DILF(.DA)
 S A=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN) Q:'A ""
 D BLD^DIALOG(200) Q ""
N9(FN,DA) Q:$G(DA)="" 0 N N9 S N9=$$ROOT($$UP(FN),"",1) Q:N9="" 0 Q:$D(@N9@($$DA(.DA),-9)) 1 Q 0
DA(Y) Q:$D(Y)=1 Y Q Y($O(Y(""),-1))
UP(Y,A) N D
 S A(0)=Y F D=0:-1 Q:'$D(^DD(+A(D),0,"UP"))  S A(D-1)=$P(^("UP"),"^")_"^"_$P($P(^DD($P(^("UP"),"^"),$O(^DD($P(^("UP"),"^"),"SB",+A(D),"")),0),"^",4),";")
 Q $P(A($O(A(""))),"^")
CREF(X) ;
ENCREF N L,X1,X2,X3 S X1=$P(X,"("),X2=$P(X,"(",2,99),L=$L(X2),X3=$TR($E(X2,L),",)"),X2=$E(X2,1,(L-1))_X3 Q X1_$S(X2]"":"("_X2_")",1:"")
OREF(X) ;
ENOREF N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 %  S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
RCP(%DIQGRCP) Q $$CREF($$R^DIQGU0(%DIQGRCP))
Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
DY(Y) S %=$E(Y,4,5)*3 Q $E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":"@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)_$S($E(Y,13,14):":"_$E(Y_0,13,14),1:""),1:"")
DAIEN(IEN,DA) ;
 K DA
 S DA=$P(IEN,",")
 N I F I=2:1 Q:$P(IEN,",",I)=""  S DA(I-1)=$P(IEN,",",I)
 Q
 ;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIOUTPUT) ;SEA/TOAD
 G XTRNLX^DIDU
 ;

DIQGU0
DIQGU0 ;SFISC/DCL-DATA RETRIVIAL UTILITY PROGRAM ;02:42 PM  24 Aug 1993;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
R(%R) ;
 N %C,%F,%G,%I,%R1,%R2
 S %R1=$P(%R,"(")_"(" I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
 S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
 S %C=$L(%R2,","),%F=1 F %I=1:1:%C S %G=$P(%R2,",",%F,%I) Q:%G=""  I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1
 Q %R1_%R2
S(%Z) ;
 I $G(%Z)']"" Q ""
 I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
 I +%Z=%Z Q %Z
 I %Z="""""" Q ""
 I $E(%Z)'?1A,"%$+@"'[$E(%Z) Q %Z
 I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
 I $D(@%Z) Q $$Q(@%Z)
 Q %Z
Q(%Z) ;
 S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
DDLST(DDN,ATRN,FL) ;
 N X,Y S:$D(^DD(DDN)) ATRN(DDN)="" S FL=+$G(FL)
 D  S X=0 F  S X=$O(^DD(DDN,"SB",X)) Q:X'>0  S ATRN(X)="" D  D DDLST(X,.ATRN,FL)
 .I 'FL S Y="" F  S Y=$O(^DD(DDN,"B",Y)) Q:Y=""  S ATRN(Y,DDN)=$O(^(Y,""))
 .Q
 Q
DDN(ATN,F) ;
 N DNA,DDN,X,Y S X="$$$ NO SUCH ATTRIBUTE $$$"
 Q:$G(ATN)']"" X
 D DDLST(+$G(F),.DNA,1)
 S DDN="" F  S DDN=$O(DNA(DDN)) Q:DDN=""  D  Q:X
 .S Y="" F  S Y=$O(^DD(DDN,"B",Y)) Q:Y=""  I Y=ATN S X=DDN_"^"_$O(^DD(DDN,"B",Y,"")) Q
 .Q
 I '$G(F),$E(X,1,6)="$$$ NO" Q $$DDN(ATN,1)
 Q X
DDLST2(DDN,ATRN,FL) ;
 N X,Y S:$D(^DD(DDN)) ATRN(DDN)="" S FL='$D(FL)
 S X=0 F  S X=$O(^DD(DDN,"SB",X)) Q:X'>0  D
 .I FL S ATRN(X)="",Y=0 F  S Y=$O(^DD(DDN,Y)) Q:Y'>0  S ATRN(Y,DDN)=$P($G(^(Y,0)),"^")
 .D DDLST2(X,.ATRN)
 .Q
 Q

DIQQ
DIQQ ;SFISC/GFT-VARIOUS HELPS ;11/18/93  09:59
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIP ;
 W !?9,"TYPE '-' IN FRONT OF NUMERIC-VALUED FIELD TO SORT FROM HI TO LO"
 D:$G(DDXP)'=4
 . W !?9,"TYPE '+' IN FRONT OF FIELD NAME TO GET SUBTOTALS BY THAT FIELD,"
 . W !?12,"'#' TO PAGE-FEED ON EACH FIELD VALUE,  '!' TO GET RANKING NUMBER,"
 . W !?12,"'@' TO SUPPRESS SUB-HEADER,   ']' TO FORCE SAVING SORT TEMPLATE"
 . W !?9,"TYPE ';TXT' AFTER FREE-TEXT FIELDS TO SORT NUMBERS AS TEXT" Q
 W:DJ=1 !?9,"TYPE [TEMPLATE NAME] IN BRACKETS TO SORT BY PREVIOUS SEARCH RESULTS" Q
 ;
DIP3 W !,"SINCE YOU ARE CALLING FOR OUTPUT ON DEVICE '",IO,"', YOU MAY USE ",!,"THE TERMINAL YOU ARE NOW TYPING ON FOR SOMETHING ELSE, BY ANSWERING 'Y'",!!
 G FREE^DIP3
 ;
DIP1F G:X["??" 11
 W !,"TO ",DE," IN SEQUENCE, STARTING FROM" G 1
DIP1T G:X["??" 11
 W !,"TO ",DE," ONLY UP TO"
1 W " A CERTAIN ",R,",",!?5,"TYPE THAT ",R W:$P(DC,U,1)'["R"&$L(DC) !?5,"'@' MEANS 'INCLUDE NULL ",R," FIELDS'"
11 I $P(DPP(DJ),U) S %=$P(DPP(DJ),U,2)+$P($P(DPP(DJ),U,4),"""",2) I % W ! D EN^DIQQ1($P(DPP(DJ),U),%,$S(X["??":"??",1:"?"))
 Q
 ;
DICATT3 W "TYPE FIELD NAMES, OPERATORS(+-\/*), DIGITS, OR FUNCTIONS",!,"FOR FUNCTIONS,"
 S D="B",DZ="??",DIC("W")="W:$D(^(9)) ""  ("",^(9),"")""",DIC="^DD(""FUNC"",",DIC(0)="" D DQ^DICQ G 6^DICATT3
 ;
DICATT31 W !,"ENTER THE NUMBER OF DIGITS THAT SHOULD NORMALLY APPEAR TO THE"
 W !,"RIGHT OF THE DECIMAL POINT WHEN '",F,"' IS DISPLAYED" G DEC^DICATT3
 ;
DIP2 ;
 I $G(DDXP)=2 D  G F^DIP2
 . W !!?5,"YOU CAN ALSO ENTER A COMPUTED EXPRESSION."
 . W:DE="" !?5,"ENTER '[TEMPLATE NAME]' TO USE AN EXISTING SELECTED EXPORT FIELDS TEMPLATE."
 . W !
 . Q
 W:$P(DU,U,4)>1 !?5,"TYPE 'ALL' TO PRINT EVERY ",$P(DU,U,1)
 W !?5,"TYPE '&' IN FRONT OF FIELD NAME TO GET TOTAL FOR THAT FIELD,",!?8,"'!' TO GET COUNT, '+' TO GET TOTAL & COUNT, '#' TO GET MAX & MIN,",!?8,"']' TO FORCE SAVING PRINT TEMPLATE"
 W:DE="" !?5,"TYPE '[TEMPLATE NAME]' IN BRACKETS TO USE AN EXISTING PRINT TEMPLATE"
 W !?5,"YOU CAN FOLLOW FIELD NAME WITH ';' AND FORMAT SPECIFICATION(S)"
 G F^DIP2
 ;
DICE2 ;
 W !!,"YOU MAY USE '@' TO INDICATE THAT '",DNEW,"' IS TO BE DELETED",!,"IF YOU SIMPLY WANT TO MOVE THE VALUE OF '",DOLD,"' OVER,",!,"   JUST ENTER '",DOLD,"'"
 G C^DICE2
DIARQ ;ARCHIVING ERROR MESSAGES
FER W !,$C(7),"Less than 'FROM SELECT CRITERIA VALUE'.",$P(DIARS,U,2) Q
FER1 W !,$C(7),"Less than 'FROM' value." Q
TER W !,$C(7),"Less than 'TO SELECT CRITERIA VALUE'.",$P(DIARE,U,2) Q
TER1 W !,$C(7),"Less than 'TO' value." Q
 ;
ENTT W !!,"_____________________________________________________________________________",!!,$C(7),"A field in the 'SELECT CRITERIA TEMPLATE being used does NOT MATCH."
 W !,"the field at the SAME LEVEL in the BASE SELECT CRITERIA SORT TEMPLATE"
 W !,"specified for this file.  There must be a one to one correspondence"
 W !,"between the fields in the template you want to use and the"
 W !,"BASIC SELECT CRITERIA SORT TEMPLATE, until all the fields in the"
 W !,"BASIC SELECT CRITERIA SORT TEMPLATE have been satisfied.  More"
 W !,"CRITERIA may exist after that.  See the development staff of the Package"
 W !,"or the ARCHIVING DOCUMENTATION where this process is explained further"
 W !,"for more information."
 W !,"_____________________________________________________________________________"
 Q

DIQQ1
DIQQ1 ;SFISC/TKW-NONDESTRUCTIVE ONLINE HELP FOR FIELDS ;4/4/95  09:16
 ;;21.0;VA FileMan;**3**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN(DP,D,X) ; DP=file no.,D=field no.,X="?" or "??"
 Q:'$G(DP)  Q:'$G(D)  Q:$G(X)'?1"?"."?"
 N %,%DT,A1,A2,DA,DC,DDH,DG,DIC,DIG,DIRUT,DISORT,DTOUT,DUOUT,DO,DQ,DST,DU,DV,DZ,Y
 S DISORT=1
1 S DQ="^DD("_DP_","_D_",0)",DQ(1)=$G(@(DQ)),DQ=1,DV=$TR($P(DQ(DQ),U,2),"V","F"),DU=$P(DQ(DQ),U,3),DZ=X Q:DQ(1)=""
 I DV S DP=+DV,D=.01 G 1
 I DV["P" N %Y,%W,%W1,%Z,C,DD,DDC,DDD,DF,DIAC,DIE,DICP,DICR,DICS,DICW,DICQ1Q,DIEQ,DIFILE,DILCV,DIPGM,DIW,DIX,DIY,DIZ,DS,IOX,IOY S DIE=""
 D EN1^DIEQ Q

DIQQQ
DIQQQ ;SFISC/GFT,XAK-MORE HELP ;9/16/93  16:20 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
DICATT W !,"IF YOU WANT THE SAME ANSWER ALLOWED FOR ",F,!,"AS FOR " Q
 ;
DICATT1 W !,"ENTER GLOBAL SUBSCRIPT NAME AT WHICH ",F," WILL BE STORED"
 W !,"   ALREADY ASSIGNED: " S Y="",T=0 F  S Y=$O(^DD(A,"GL",Y)) Q:Y=""  W $J(Y,9) W:$X>66 !
 S Y=-1 G SUB^DICATT1
 ;
DIS ;
 W !?8,"ENTER A VALUE WHICH '"_O(DC)_"'"
 W !?8,"MUST "_$P("NOT ",U,DN]"")_$P("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ)_", IN ORDER FOR"
 W " TRUTH CONDITION -"_$C(DC+64)_"- TO BE TRUE",! W:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",!
 I E["S" W !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?")
 W ! G F^DIS
 ;
DISC W !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-"""
 W !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",! G C^DIS
 ;
DIP1 W $C(7),!,"YOU HAVE ASKED TO SORT ON THE SAME FIELD TWICE!",!,"PLEASE RE-ENTER YOUR SORT CRITERIA!" G Q^DIP
 ;
DIP3 W !,"IF YOU WANT PAGE NUMBERING TO START AT A NUMBER HIGHER THAN 1, TYPE THAT NUMBER" G ^DIP3
 ;
DIA W "FOLLOW A FIELD NAME WITH ';""CAPTION""' TO HAVE THE FIELD ASKED AS 'CAPTION: '"
 W !?9,"OR WITH ';T' TO USE THE FIELD 'TITLE' AS CAPTION"
 G 2^DIA
 ;
DIA3 W !,$C(7),"CAPTIONS CANNOT CONTAIN ':' OR ';', OR BEGIN WITH A PERIOD OR A DIGIT",! G 2^DIA
 ;
DIP21 W !,"THIS TEMPLATE MAY EVENTUALLY BE USED WITH A DIFFERENT 'SORT-BY' SEQUENCE.",!
 W "ANSWERING 'Y' HERE INSURES THAT, IN THAT CASE, USER WON'T HAVE TO REMEMBER"
 W !,"TO TYPE THE '@' IN ORDER TO KEEP SUB-HEADERS FROM APPEARING.",! G SUB^DIP21
 ;
DICOMPW W !?4,"AT THE TIME THE LOOKUP OCCURS IN FILE "_Y_", THERE MAY"
 W !?4,"BE MORE THAN 1 ENTRY FOUND.  ANSWERING 'Y' HERE MEANS THAT THE"
 W !?4,"USER THEN WILL BE ALLOWED TO CHOOSE AMONG SEVERAL ENTRIES.",!! Q
XPDIP21 ;from XPUT^DIP21
 W !!,$C(7),"You must choose a template to store the fields selected for export."
 W !,"If you do not want to save the selections, use the '^'.",! Q

DIR
DIR ;SFISC/XAK-READER, HELP ;02:29 PM  30 May 1995
 ;;21.0;VA FileMan;**13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y,A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1,XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
 S:$D(DDH)[0 DDH=0 Q:'$D(DIR(0))  D ^DIR2 G Q:%T=""
 I $D(DIR("V"))#2 D ^DIR1 S DDER=%E G Q
A I $D(DDM) K:DDM DDQ S:'DDM DDQ=IOSL-7
 I $G(DDH) D LIST^DDSU
 D W:%A'["V" I $D(DDS),$D(DIR0) S DDACT=Y I DDO=.5 S DDM=1 G Q
 I $D(DTOUT) K Y S DIRUT=1,Y="" G Q
 I %T'="E",X?1."^".E K Y S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 S:%T="Y" %=-1 G Q
 I %T'="E","@"[X,%A["O" S Y="",DIRUT=1 S:%T="P" Y=-1 G Q
 I %A'["O","@"[X,%T'="E" S A0=$C(7)_%A0 D MSG G A
 I $D(DDS),$D(DIR0),DIR0N G Q
 I $D(%G),$D(DIR("B")),X=DIR("B") S Y=%G G Q
 I X'?1."?" K DDQ D ^DIR1 I '%E,$P(DIR(0),U,3)]"" S %X=X X $P(DIR(0),U,3,99) S:'$D(X) %E=1 S X=%X
 I %A["V" K:%E Y G Q
 I X?1."?"!%E D QUES:%E'<0 S A0="" D MSG D:$G(DDH) LIST^DDSU G A
 G Q
 ;
W ;
 S %W=%W0,%N=$E(%W)=U
 K DTOUT,DUOUT,DIRUT,DIROUT S %E=0 I $D(DDS),$D(DIR0) D ^DIR0 Q
 I %T="S",%A'["A",%A'["B" D S
 I $D(DIR("A"))=11 F %=0:0 S %=$O(DIR("A",%)) Q:%'>0  W !,DIR("A",%)
 W ! W:$L(%P) %P
 I $D(DIR("B")) W DIR("B") I $L(DIR("B"))<20!(%T="D")!(%T="S")!((%B["D"&%T)) W "// "
 I %T'="D",$D(DIR("B")),$L(DIR("B"))>19,%T'="S",(%B'["D"&%T)!'%T S Y=DIR("B") D RW^DIR2 S:X="" X=DIR("B") Q
 R X:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME) I '$T S DTOUT=1
 I X="",$D(DIR("B")) S X=DIR("B") I %T'="D",%B'["D"&%T W X
 I X'?.ANP S X="?"
 Q
 ;
QU I %E!(X="?")!($O(^DD(%B1,%B2,21,0))'>0) K %Y S A0="" D MSG F %C=3,12 I $D(^DD(%B1,%B2,%C)) S X1=^(%C),%J=75,%Y=1 D W1
 I $D(^DD(%B1,%B2,4)) S A0=^(4),A0(0)=1 D MSG
 I X?1"??".E D
 . I $D(DDS) N DDC,DDSQ S DDC=7
 . S A0="" D MSG S %C=0
 . F  S %C=$O(^DD(%B1,%B2,21,%C)) Q:'%C!$D(DDSQ)  S A0=^(%C,0) D
 .. I $D(DDS),$G(DDH),'(DDH#DDC) D LIST^DDSU Q:$D(DDSQ)
 .. D MSG
 I %B["P" K DO S DIC=U_$P(%B3,U,3),DIC(0)="M"_$E("L",%B'["'") D AST:%B["*",DQ
 I %B["D" S %DT=$P($P($P(%B3,U,5,99),"%DT=""",2),"""",1) D HELP^%DTC
 I %B["S" X:$D(^DD(%B1,%B2,12.1)) ^(12.1) S A0=$$EZBLD^DIALOG(8068)_" " D MSG F %C=1:1 S Y=$P($P(%B3,U,3),";",%C) Q:Y=""  S %I=$P(Y,":",2),Y=$P(Y,":") I 1 X:$D(DIC("S")) DIC("S") I  S A0=Y_$E("         ",$L(Y)+1,999)_%I D MSG
 I %B["V" S A0="" D MSG S X1=X,DU=%B1,D=%B2,DZ=X D V^DIEQ S X=X1
 Q
DQ N %W S:$D(D)[0 D="B" S (X1,DZ)=X D DQ^DICQ S DDSV=DIC K DD,% S:$D(X1) X=X1
 Q
AST F %=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(%B3,%),%=$L(%)+1 Q:Y
 Q:'Y
 I $D(DDS) S A0=" " D MSG
 X $P($E(%B3,1,Y-%),U,5,99)
 Q
QUES ;
 I %T D QU
 I X="??",$D(DIR("??")) D:$P(DIR("??"),U)]"" HF S:$P(DIR("??"),U,2)]"" A0(0)=1,A0=$P(DIR("??"),U,2,99) D:$P(DIR("??"),U,2)]"" MSG Q
 I %T="P" S DIC=%B1,DIC(0)=%B2 S:$D(DIR("S"))#2 DIC("S")=DIR("S") D DQ K DIC("S")
 I '%N S A0="" D MSG
 I X'["?" W $C(7)
 I %N S A0(0)=1,A0=$E(%W,2,999) D MSG
 D:'%N WRAP:%W]"" I %T["S",(%A["A"!(%A["B")) D S
 Q
WRAP I $D(DIR("?"))=11 F %I=1:1 Q:'$D(DIR("?",%I))  S A0=DIR("?",%I) D MSG
 K %Y S %J=$S($D(IOM):IOM,1:80)-6,%Y=1 S X1=$S($D(DIR("?"))=11:DIR("?"),1:%W)
 I '%N,$D(DIR("?"))'=11,"FNDL"[%T S X1=X1_"."
W1 S:$L(X1)<%J %Y(%Y)=X1 I $L(X1)'<%J F %I=%J:-1:0 I $E(X1,%I)?1P S %Y(%Y)=$E(X1,1,%I),X1=$E(X1,%I+1,999),%Y=%Y+1 G W1
 F %I=1:1:%Y S A0=%Y(%I) D MSG
 I $D(DDS),%T="S" D
 . S A0="Choose from:" D MSG
 . F %I=1:1 Q:$P(%B,";",%I,999)=""  D
 .. S %Y=$P(%B,";",%I),Y=$P(%Y,":") Q:Y=""
 .. I $D(DIR("S"))#2 X DIR("S") E  Q
 .. S A0=Y_$J("",9-$L(Y))_$P(%Y,":",2) D MSG
 K %Y,%,X1
 Q
HF S XQH=$P(DIR("??"),U) N %A,%B,%E,DIR D EN1^XQH
 Q
MSG ;
 I $D(DDS),A0]"" D
 . S DDH=$G(DDH)+1
 . I $D(A0)>9 S DDH(DDH,"T")="",DDH=DDH+1,DDH(DDH,"X")=A0
 . E  S DDH(DDH,"T")=A0
 I '$D(DDS),$D(A0)>9 W:$X ! X A0
 I '$D(DDS),$D(A0)=1 W !,A0
 K A0
 Q
S W !!?5,"Select one of the following:",!!
 F %I=1:1 Q:$P(%B,";",%I,999)=""  D
 . S Y=$P($P(%B,";",%I),":") Q:'$L($P(%B,";",%I,99))
 . I $D(DIR("S"))#2 X DIR("S") E  Q
 . W ?10,Y,?20,$P($P(%B,";",%I),":",2),!
 Q
Q G ^DIRQ
 ;
 ;#8068  Choose from

DIR0
DIR0 ;SFISC/MKO-FIELD EDITOR ;11:32 AM  15 Feb 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
SM ;
 N DIR0A,DIR0C,DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0L,DIR0M
 N DIR0P,DIR0QT,DIR0QU,DIR0R,DIR0RJ,DIR0S,DIR0SP,DIR0ST,DIR0SV,DX,DY
 S DIR0P="" D:$D(DIR0("IN"))[0 GETKEY^DIR0K
 S:$P(DIR0,U,6) DIR0RJ=1
 ;
 I $G(DDSH) D
 . K DDSH
 . S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)
 . I DDO,'DDM W "COMMAND:"
 . S DX=IOM-33 X IOXY W $P(DDGLVID,DDGLDEL,10)_$$EZBLD^DIALOG(8074)
 . S DX=IOM-8 X IOXY
 . W $P(DDGLVID,DDGLDEL,6)_$P($$EZBLD^DIALOG(7002),U,$G(DIR0("REP"))>0+1)_$P(DDGLVID,DDGLDEL,10)
 ;
 S (DIR0A,DIR0D)=$G(DIR("B"))
 S DIR0R=$P(DIR0,U),DIR0S=$P(DIR0,U,2),DIR0L=$P(DIR0,U,3),DIR0M=245
 ;
 W $P(DDGLVID,DDGLDEL,10)
 S DY=$P(DIR0,U,4),DX=$P(DIR0,U,5)
 I $D(DIR("A"))=11 D
 . N DIX
 . S DIX="" F  S DIX=$O(DIR("A",DIX)) Q:DIX=""  D
 .. X IOXY W DIR("A",DIX)
 .. S DY=DY+1
 ;
 I $D(DIR("A"))#2 D
 . X IOXY W DIR("A")
 . I DDO,DY=IOSL-1 W $P(DDGLCLR,DDGLDEL)
 ;
 D INIT,^DIR01
 ;
 I $D(DTOUT) W $C(7) S DIR0A=DIR0D
 I DIR0A="@",DIR0D'="@" S DIR0A=""
 S:DIR0CH="QT" DIR0A=DIR0D
 S X=DIR0A
 S:X?1"^".E!(X?1"?".E) DIR0A=DIR0D
 S DIR0N=X=DIR0D S:DIR0A'=DIR0D DIR0("L")=DIR0A
 ;
 D END,PAINT
 X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
 Q
 ;
EN(DIR0R,DIR0S,DIR0L,DIR0NL,DIR0A,DIR0M,DIR0C,DIR0MAP,DIR0FLG,X,Y) ;
 ;Field editor
 N DIR0CH,DIR0CHG,DIR0D,DIR0F,DIR0KD,DIR0P,DIR0QT,DIR0QU
 N DIR0RJ,DIR0SP,DIR0ST,DIR0SV,DIR0TO,DX,DY
 ;
 D INIT^DDGLIB0()
 ;
 I $D(DIR0MAP)<2 D
 . S DIR0P="D"
 . D:$D(DIR0("DIN"))[0 GETKEY^DIR0K
 E  D
 . S DIR0P="C"
 . I $O(DIR0MAP(""))!($D(DIR0MAP("IN"))[0) D
 .. D GETKEY^DIR0K
 .. K DIR0MAP S DIR0MAP("IN")=DIR0("CIN"),DIR0MAP("OUT")=DIR0("COUT")
 . E  D
 .. S DIR0("CIN")=$G(DIR0MAP("IN")),DIR0("COUT")=$G(DIR0MAP("OUT"))
 .. S:DIR0("CIN")[(U_"KD"_U) DIR0KD=$P(DIR0("COUT"),";",$L($P(DIR0("CIN"),U_"KD"_U),U))
 .. S:DIR0("CIN")[(U_"TO"_U) DIR0TO=$P(DIR0("COUT"),";",$L($P(DIR0("CIN"),U_"TO"_U),U))
 ;
 S (DIR0A,DIR0D)=$G(DIR0A)
 S:'$G(DIR0R) DIR0R=0
 S:'$G(DIR0S) DIR0S=0
 S:'$G(DIR0L) DIR0L=IOM-1-DIR0S
 S:'$G(DIR0M) DIR0M=245
 S:'$G(DIR0FLG)["r" DIR0RJ=1
 ;
 I $G(DIR0NL)>1 D
 . D EN^DIR02,END
 E  D INIT,^DIR01,END,PAINT
 ;
 S X=DIR0A
 I $D(DTOUT) K DTOUT S:Y="" Y="TO"
 S $P(Y,U,2)=+$G(DIR0CHG)
 D KILL^DDGLIB0($G(DIR0FLG))
 K DIR0("CIN"),DIR0("COUT")
 Q
 ;
INIT ;
 K DTOUT
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 S DIR0SV=$G(DIR0("L"))
 S DIR0C=$S($G(DIR0C)<1:0,1:DIR0C)+1
 S:DIR0C-1>$L(DIR0A) DIR0C=$L(DIR0A)+1
 S (DIR0QT,DIR0QU)=0,DY=DIR0R,DX=DIR0S,DIR0F=DIR0S+DIR0L
 ;
 X IOXY
 S DIR0SP=$J("",DIR0L) S:$G(DDGLVAN) DIR0SP=$TR(DIR0SP," ","_")
 I DIR0C-1>DIR0L D
 . W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$E(DIR0A,DIR0C-DIR0L,DIR0C-1)
 . S DX=DIR0F
 E  D
 . W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
 . S DX=DIR0S+DIR0C-1
 . X IOXY
 Q
 ;
END ;
 S Y=$P("U^D^R^L^N^NB^NP^PP^SEL^EX^QT^CL^SV^RF",U,$L($P("^UP^DOWN^TAB^FDL^CR^NB^NP^PP^SEL^EX^QT^CL^SV^RF^",U_DIR0CH_U),U))
 S:Y="" Y=$P($G(DIR0QT),U,2)
 N X,Y S DIR0SP=$TR(DIR0SP,"_"," ")
 S DIR0C=DIR0C-1
 Q
 ;
PAINT ;
 N DIR0X
 I $G(DIR0FLG)["P" W $P(DDGLVID,DDGLDEL,10) Q
 I '$G(DIR0RJ) S DIR0X=$E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
 E  S DIR0X=$E(DIR0SP,$L(DIR0A)+1,999)_$E(DIR0A,1,DIR0L)
 S DX=DIR0S X IOXY
 W $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL)_DIR0X_$P(DDGLVID,DDGLDEL,10)
 Q
 ;
UPDATE(DIR0NA,DIR0NC) ;Update ans/curs pos
 N DIR0STR,DIR0X
 S:$D(DIR0NA)[0 DIR0NA=DIR0A
 S DIR0NC=$S($D(DIR0NC)[0:DIR0C-1,1:DIR0NC)+1
 S:DIR0NC<1 DIR0NC=1
 S:DIR0NC-1>$L(DIR0NA) DIR0NC=$L(DIR0NA)+1
 S DIR0X=DX+DIR0NC-DIR0C
 ;
 I DIR0A=DIR0NA,DIR0X'<DIR0S,DIR0X'>DIR0F D
 . S DX=DIR0X X IOXY
 E  D
 . S DIR0X=DIR0NC-DIR0L S:DIR0X<1 DIR0X=1
 . S DX=DIR0S X IOXY
 . S DIR0STR=$E(DIR0NA,DIR0X,DIR0X+DIR0L-1)
 . W DIR0STR_$E(DIR0SP,$L(DIR0STR)+1,999)
 . S DX=DIR0S+DIR0NC-DIR0X X IOXY
 ;
 S DIR0A=DIR0NA,DIR0C=DIR0NC
 Q
 ;
KILL ;
 D KILL^DDGLIB0()
 Q
 ;
 ;#8074  Press <PF1>H for help
 ;#7002  Insert^Replace

DIR01
DIR01 ;SFISC/MKO-FIELD EDITOR ;12:37 PM  15 Feb 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DIR0A]"",DIR0C=1 D F X IOXY Q:DIR0QT
 F  D E X IOXY Q:DIR0QT
 Q
 ;
F D READ(.DIR0CH)
 I "?^"'[DIR0CH=$L(DIR0CH) S DIR0A="" D REP,DEOF Q
 D:DIR0CH]"" E1
 Q
 ;
E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),DIR0F>DX,DIR0M>$L(DIR0A),'$D(DIR0KD) D
 . D PREAD($$MIN(DIR0F-DX,DIR0M-DIR0C+1),.DIR0ST,.DIR0CH)
 . Q:DIR0ST=""
 . S DIR0CHG=1
 . I '$G(DIR0("REP")) S DIR0A=DIR0A_DIR0ST
 . E  S $E(DIR0A,DIR0C,DIR0C+$L(DIR0ST)-1)=DIR0ST
 . S DX=DX+$L(DIR0ST),DIR0C=DIR0C+$L(DIR0ST)
 E  D READ(.DIR0CH)
 Q:DIR0CH=""
 ;
E1 I "?^"[DIR0CH,DIR0C=1,'DIR0QU S DIR0A="",DIR0QU=1 D REP,DEOF Q
 D @$S($L(DIR0CH)>1:DIR0CH,$G(DIR0("REP")):"REP",1:"INS")
 I DIR0QU,"?^"'[$E(DIR0A)!'$L(DIR0A) S DIR0QU=0,DIR0A="" D CLR
 Q
 ;
REP I DIR0C>DIR0M W $C(7) Q
 S DIR0CHG=1
 S $E(DIR0A,DIR0C)=DIR0CH,DIR0C=DIR0C+1
 I DIR0F>DX S DX=DX+1 W DIR0CH Q
 N DIX
 S DIX=DIR0C-(DIR0L\2)
 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
 S DX=DIR0S X IOXY
 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
 Q
 ;
INS I $L(DIR0A)'<DIR0M W $C(7) Q
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C,999),DIR0C=DIR0C+1
 I DIR0F>DX S DX=DX+1 W $E(DIR0A,DIR0C-1,DIR0C+DIR0F-DX-1) Q
 S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1) S DX=DIR0F
 Q
 ;
RIGHT Q:DIR0C>$L(DIR0A)
 I DX<DIR0F S DX=DX+1,DIR0C=DIR0C+1 Q
 S DIR0C=DIR0C+1,DX=DIR0S X IOXY
 W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
 S DX=DIR0F
 Q
 ;
LEFT Q:DIR0C'>1
 I DX>DIR0S S DX=DX-1,DIR0C=DIR0C-1 Q
 S DIR0C=DIR0C-1 W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
 Q
 ;
JRT Q:DIR0C>$L(DIR0A)
 I DIR0F=DX D  Q
 . S DIR0C=DIR0C+DIR0L S:DIR0C+1>$L(DIR0A) DIR0C=$L(DIR0A)+1
 . S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
 . S DX=DIR0F
 N DIX
 S DIX=$L(DIR0A)-DIR0C+1
 I DIR0F-DX>DIX S DX=DX+DIX,DIR0C=DIR0C+DIX Q
 S DIR0C=DIR0C+DIR0F-DX,DX=DIR0F
 Q
 ;
JLT Q:DIR0C'>1
 I DX=DIR0S D  Q
 . S DIR0C=DIR0C-DIR0L S:DIR0C<1 DIR0C=1
 . W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
 S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
 Q
 ;
FDE Q:DIR0C>$L(DIR0A)
 I DX+$L(DIR0A)-DIR0C-DIR0L<DIR0S D  Q
 . S DX=DX+$L(DIR0A)-DIR0C+1,DIR0C=$L(DIR0A)+1
 S DIR0C=$L(DIR0A)+1,DX=DIR0S X IOXY
 W $E(DIR0A,DIR0C-DIR0L,DIR0C)
 S DX=DIR0F
 Q
 ;
FDB Q:DIR0C'>1
 I DX-DIR0C+1<DIR0S S DX=DIR0S X IOXY W $E(DIR0A,1,DIR0L)
 S DX=DIR0S,DIR0C=1
 Q
 ;
BS Q:DIR0C'>1
 S DIR0CHG=1
 S DIR0C=DIR0C-1,DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
 I DX>DIR0S D  Q
 . S DX=DX-1 X IOXY
 . W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
 N DIX
 S DIX=DIR0C-(DIR0L\2)
 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
 S:DIX<1 DIX=1
 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
 Q
 ;
DEL Q:DIR0C>$L(DIR0A)!(DIR0F'>DX)
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
 W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
 Q
 ;
CLR S DIR0CHG=1
 S DIR0C=1,DX=DIR0S X IOXY
 I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
 S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
 W $E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
 Q
 ;
DEOF S DIR0CHG=1
 W $E(DIR0SP,DX-DIR0S+1,999)
 S DIR0A=$E(DIR0A,1,DIR0C-1)
 Q
 ;
RPM N DX,DY
 I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
 I $G(DIR0("REP")) W:$D(DDS) "Insert " K DIR0("REP")
 E  W:$D(DDS) "Replace" S DIR0("REP")=1
 Q
 ;
KPM I $G(DDGLKPNM) K DDGLKPNM W $P(DDGLED,DDGLDEL,9)
 E  S DDGLKPNM=1 W $P(DDGLED,DDGLDEL,10)
 Q
 ;
WRT G WRT^DIR0W
WLT G WLT^DIR0W
DLW G DLW^DIR0W
HLP G ^DIR0H
ZM G SM^DIR02
 ;
TO I $D(DIR0TO)#2 D @DIR0TO Q
 S DTOUT=1
UP ;
DOWN ;
TAB ;
FDL ;
CR ;
NB ;
NP ;
PP ;
SEL ;
EX ;
QT ;
CL ;
SV ;
RF ;
 S DIR0QT=1
 Q
NOP W $C(7)
 Q
 ;
READ(Y) ;Out: Y=char or mnemonic
 F  D  Q:Y'=-1
 . R *Y:DTIME
 . I Y>31,Y<127 S Y=$C(Y) Q
 . I Y<0 S Y="TO" Q
 . D MNE(.Y)
 I Y'="TO",$D(DIR0KD) D @DIR0KD
 Q
 ;
PREAD(DIR0LEN,DIR0ST,Y) ;
 ; Y = Mnem, Null if DIR0LEN chars read or invalid
 X DDGLZOSF("EON")
 R DIR0ST#DIR0LEN:DTIME E  S Y="TO" Q
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
 I $C(Y)?1C,Y D
 . D MNE(.Y) S:Y=-1 Y=""
 E  S Y=""
 Q
 ;
MNE(Y) ;Out: Y=mnemonic, or -1 if invalid
 N S,F
 S S="",F=0
 F  D MNELOOP Q:F
 Q
 ;
MNELOOP ;
 S S=S_$C(Y)
 I DIR0(DIR0P_"IN")'[(U_S) D  I Y=-1 D FLUSH Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32)
 . S:DIR0(DIR0P_"IN")'[(U_S_U) Y=-1
 ;
 I DIR0(DIR0P_"IN")[(U_S_U),S'=$C(27) D
 . S Y=$P(DIR0(DIR0P_"OUT"),";",$L($P(DIR0(DIR0P_"IN"),U_S_U),U)),F=1
 E  R *Y:5 D:Y=-1 FLUSH
 Q
 ;
FLUSH N X
 S F=1 W $C(7) F  R *X:0 E  Q
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)

DIR02
DIR02 ;SFISC/MKO-MULTILINE FIELD EDITOR ;3:24 PM  29 Aug 1995
 ;;21.0;VA FileMan;**6,11**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N DIR0FL,DIR0LN,DIR0NC,DIR0QU
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")
 S DIR0QU=0
 ;
 S:$D(DIR0C)#2 DIR0C=DIR0C+1
 D INIT,^DIR03
 W $P(DDGLVID,DDGLDEL,7)
 Q
 ;
SM ;ScreenMan's entry point, called from ^DIR01
 N DIR0DN,DIR0FL,DIR0LN,DIR0NC,DIR0NL
 S DIR0R=IOSL-6,DIR0S=0,DIR0L=IOM-1,DIR0NL=4
 ;
 D INIT,^DIR03
 ;
 S:$D(DTOUT) DIR0A=DIR0D
 ;
 ;Restore command area
 S DY=DIR0R,DX=DIR0S X IOXY
 W $P(DDGLVID,DDGLDEL,10)_$P(DDGLCLR,DDGLDEL,3)
 ;
 S DY=IOSL-1
 I DDO D
 . S DX=0 X IOXY W "COMMAND:"
 . S DX=IOM-35 X IOXY W "Press <PF1>H for help"
 S DX=IOM-8 X IOXY
 W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$S($G(DIR0("REP")):"Replace",1:"Insert ")_$P(DDGLVID,DDGLDEL,10)
 ;
 ;Restore variables
 S (DY,DIR0R)=$P(DIR0,U),(DX,DIR0S)=$P(DIR0,U,2),DIR0L=$P(DIR0,U,3)
 S DIR0F=DIR0S+DIR0L
 S DIR0SP=$J("",DIR0L) S:$G(DDGLVAN) DIR0SP=$TR(DIR0SP," ","_")
 I DIR0A]"","^?"[$E(DIR0A) S DIR0QT=1
 ;
 ;Repaint answer
 X IOXY
 W:'$D(DDGLVAN) $P(DDGLVID,DDGLDEL,6)
 I DIR0C>DIR0L D
 . W $E(DIR0A,DIR0C-DIR0L+1,DIR0C)_$E(DIR0SP,DIR0C>$L(DIR0A))
 . S DX=DIR0F-1
 E  D
 . W $E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
 . S DX=DIR0S+DIR0C-1
 X IOXY
 K DTOUT
 Q
 ;
INIT ;Setup
 K DTOUT
 S:DIR0M<$L(DIR0A) DIR0M=$L(DIR0A)
 S DIR0SP=$J("",DIR0L) S:$G(DDSVAN) DIR0SP=$TR(DIR0SP," ","_")
 ;
 F DIR0LN=1:1:DIR0NL D
 . S DY=DIR0R+DIR0LN-1,DX=DIR0S X IOXY
 . S X=$E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 . W X_$E(DIR0SP,$L(X)+1,999)
 ;
 S:DIR0NL*DIR0L-1<DIR0M DIR0M=DIR0NL*DIR0L-1
 S DIR0NL=DIR0M\DIR0L+1,DIR0NC=DIR0M#DIR0L
 S DIR0F=DIR0S+DIR0L-1,DIR0FL=DIR0S+DIR0NC-1
 S DIR0SV=$G(DIR0("L")),DIR0DN=0
 ;
 S DIR0C=$S($G(DIR0C)<1:1,1:DIR0C)
 S:DIR0C-1>DIR0M DIR0C=DIR0M+1
 S DIR0LN=DIR0C\DIR0L+1
 S DY=DIR0R+DIR0LN-1,DX=DIR0S+(DIR0C#DIR0L)-1
 X IOXY
 Q
 ;
KILL ;Cleanup all variables
 D KILL^DDGLIB0()
 Q

DIR03
DIR03 ;SFISC/MKO-MULTILINE FIELD EDITOR ;12:36 PM  15 Feb 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F  D E X IOXY Q:DIR0DN!$G(DIR0QT)
 Q
 ;
E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),$S(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)>DX,'$D(DIR0KD) D
 . D PREAD^DIR01($S(DIR0LN<DIR0NL:DIR0F,1:DIR0FL)-DX,.DIR0ST,.DIR0CH)
 . Q:'$L(DIR0ST)
 . I '$G(DIR0("REP")) S DIR0A=DIR0A_DIR0ST
 . E  S $E(DIR0A,DIR0C,DIR0C+$L(DIR0ST)-1)=DIR0ST
 . S DX=DX+$L(DIR0ST),DIR0C=DIR0C+$L(DIR0ST)
 E  D READ^DIR01(.DIR0CH)
 Q:DIR0CH=""
 ;
 I "?^"[DIR0CH,DIR0C=1,'DIR0QU D  Q
 . D DEOF X IOXY
 . S DIR0A="",DIR0QU=1 D REP
 D @$S($L(DIR0CH)>1:DIR0CH,$G(DIR0("REP")):"REP",1:"INS")
 I DIR0QU,"?^"'[$E(DIR0A)!'$L(DIR0A) S DIR0QU=0,DIR0A="" D CLR
 Q
 ;
REP I DIR0C>DIR0M W $C(7) Q
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C+1,999)
 S DIR0C=DIR0C+1
 W DIR0CH
 I DX<DIR0F S DX=DX+1 Q
 S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S Q
 Q
 ;
INS I $L(DIR0A)'<DIR0M W $C(7) Q
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C,999)
 W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
 D
 . N DIR0LN,DY,DX
 . S DX=DIR0S
 . F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
 .. S DY=DIR0R+DIR0LN-1 X IOXY
 .. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 S DIR0C=DIR0C+1
 I DX<DIR0F S DX=DX+1 Q
 S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S
 Q
 ;
RIGHT Q:DIR0C>$L(DIR0A)
 S DIR0C=DIR0C+1
 I DX<DIR0F!(DIR0LN=DIR0NL) S DX=DX+1 Q
 S DIR0LN=DIR0LN+1,DY=DY+1,DX=DIR0S
 Q
 ;
LEFT Q:DIR0C'>1
 S DIR0C=DIR0C-1
 I DX>DIR0S S DX=DX-1 Q
 S DIR0LN=DIR0LN-1,DY=DY-1,DX=DIR0F
 Q
 ;
JRT Q:DIR0C>$L(DIR0A)
 Q:DX=DIR0F
 S DIR0C=DIR0LN*DIR0L S:DIR0C>$L(DIR0A) DIR0C=$L(DIR0A)+1
 S DX=DIR0C#DIR0L-1+DIR0S S:DX<DIR0S DX=DIR0F
 Q
 ;
JLT Q:DIR0C'>1
 Q:DX=DIR0S
 S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
 Q
 ;
UP Q:DIR0LN=1
 S DIR0C=DIR0C-DIR0L,DIR0LN=DIR0LN-1,DY=DY-1
 Q
 ;
DOWN Q:DIR0LN=DIR0NL
 Q:$L(DIR0A)\DIR0L<DIR0LN
 S DIR0C=DIR0C+DIR0L,DIR0LN=DIR0LN+1,DY=DY+1
 S:DIR0C>($L(DIR0A)+1) DIR0C=$L(DIR0A)+1,DX=DIR0C#DIR0L+DIR0S-1
 Q
 ;
FDE ;
NP Q:DIR0C>$L(DIR0A)
 S DIR0C=$L(DIR0A)+1,DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
 S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
 S DY=DIR0R+DIR0LN-1
 Q
 ;
FDB ;
PP Q:DIR0C'>1
 S DIR0LN=1,DY=DIR0R,DX=DIR0S,DIR0C=1
 Q
 ;
BS Q:DIR0C'>1
 S DIR0CHG=1
 S DX=DX-1,DIR0C=DIR0C-1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)_" "
 I DX<DIR0S S DIR0LN=DIR0LN-1,DY=DY-1,DX=DIR0F
 X IOXY W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
 D
 . N DIR0LN,DY,DX
 . S DX=DIR0S
 . F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
 .. S DY=DIR0R+DIR0LN-1 X IOXY
 .. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 S DIR0A=$E(DIR0A,1,$L(DIR0A)-1)
 Q
 ;
DEL Q:DIR0C>$L(DIR0A)
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)_" "
 W $E(DIR0A,DIR0C,DIR0C+DIR0F-DX)
 D
 . N DIR0LN,DY,DX
 . S DX=DIR0S
 . F DIR0LN=DIR0C-1\DIR0L+2:1:$L(DIR0A)\DIR0L+1 D
 .. S DY=DIR0R+DIR0LN-1 X IOXY
 .. W $E(DIR0A,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 S DIR0A=$E(DIR0A,1,$L(DIR0A)-1)
 Q
 ;
CLR N %X
 S DIR0CHG=1
 S %X=DIR0A
 I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
 S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
 S %X=DIR0A_$J("",$L(%X)-$L(DIR0A))
 S DX=DIR0S
 F DIR0LN=1:1:$L(%X)\DIR0L+1 D
 . S DY=DIR0R+DIR0LN-1 X IOXY
 . W $E(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 S (DIR0C,DIR0LN)=1,DY=DIR0R
 Q
 ;
DEOF N %X
 Q:DIR0C>$L(DIR0A)
 S DIR0CHG=1
 S %X=DIR0A,DIR0A=$E(DIR0A,1,DIR0C-1),%X=DIR0A_$J("",$L(%X)-$L(DIR0A))
 W $E(%X,DIR0C,DIR0C+DIR0F-DX)
 D
 . N DIR0LN,DY,DX
 . S DX=DIR0S
 . F DIR0LN=DIR0C-1\DIR0L+2:1:$L(%X)\DIR0L+1 D
 .. S DY=DIR0R+DIR0LN-1 X IOXY
 .. W $E(%X,DIR0LN-1*DIR0L+1,DIR0LN*DIR0L)
 Q
 ;
RPM N DX,DY
 I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
 I $G(DIR0("REP")) W "Insert " K DIR0("REP")
 E  W "Replace" S DIR0("REP")=1
 Q
 ;
KPM I $G(DDGLKPNM) K DDGLKPNM W $P(DDGLED,DDGLDEL,9)
 E  S DDGLKPNM=1 W $P(DDGLED,DDGLDEL,10)
 Q
 ;
WRT G WRT2^DIR0W
WLT ;
FDL G WLT2^DIR0W
DLW G DLW2^DIR0W
 ;
HLP ;
NB ;
SEL ;
SV ;
RF ;
NOP W $C(7)
 Q
TO I $D(DIR0TO)#2 D @DIR0TO Q
 S DTOUT=1
ZM ;
QT ;
EX ;
CL ;
TAB ;
CR S DIR0DN=1
 Q

DIR0H
DIR0H ;SFISC/MKO-HELP FOR SCREENS ;10:59 AM  22 Jul 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIR0DX=DX,DIR0DY=DY
 W $P(DDGLVID,DDGLDEL,10)_$P(DDGLCLR,DDGLDEL,2)_$P(DDGLVID,DDGLDEL)
 D HLP^DDGLIBH(9231,9233,"DDSH",IOSL-1)
 ;
 I $D(DDS)#2 D
 . D R^DDS3
 . I $D(DDO)#2 D
 .. I 'DDO D CMD
 .. E  D
 ... K DDSH
 ... S DX=0,DY=IOSL-1 X DDXY W "COMMAND:"
 ... S DX=IOM-35 X IOXY W $P(DDGLVID,DDGLDEL,10)_"Press <PF1>H for help"
 E  W $P(DDGLCLR,DDGLDEL,2)
 ;
 S DX=IOM-8,DY=IOSL-1 X IOXY
 W $P(DDGLVID,DDGLDEL,10)_$S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_$S($G(DIR0("REP")):"Replace",1:"Insert ")_$P(DDGLVID,DDGLDEL,10)
 ;
 S DY=$P(DIR0,U,4),DX=$P(DIR0,U,5)
 I $D(DIR("A"))=11 D
 . S DIR0X=""
 . F  S DIR0X=$O(DIR("A",DIR0X)) Q:DIR0X=""  D
 .. X IOXY
 .. W DIR("A",DIR0X)
 .. S DY=DY+1
 ;
 I $D(DIR("A"))#2 D
 . X IOXY W DIR("A")
 . I $D(DDS),DDO,DY=IOSL-1 W $P(DDGLCLR,DDGLDEL)
 ;
 S DIR0X=$E(DIR0A,DIR0C-DIR0DX+DIR0S,DIR0C+DIR0F-DIR0DX-1)
 S DX=DIR0S,DY=DIR0DY X IOXY W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_DIR0X,$E(DIR0SP,$L(DIR0X)+1,999)
 S DX=DIR0DX X IOXY
 K DIR0DX,DIR0DY,DIR0X
 Q
CMD ;
 K DDH,DDQ
 F DDH=1:1 Q:$D(DIR("?",DDH))[0  S DDH(DDH,"T")=DIR("?",DDH)
 S:$D(DIR("?"))#2 DDH(DDH,"T")=DIR("?")
 D LIST^DDSU
 Q

DIR0K
DIR0K ;SFISC/MKO-GET KEYS FOR FIELD EDITOR ;12:16 PM  15 Feb 1995
 ;;21.0;VA FileMan;**6**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
GETKEY ;Get key sequences
 N AU,AD,AR,AL,F1,F2,F3,F4,I,K,T
 N REMOVE,PREVSC,NEXTSC
 S AU=$P(DDGLKEY,U,2)
 S AD=$P(DDGLKEY,U,3)
 S AR=$P(DDGLKEY,U,4)
 S AL=$P(DDGLKEY,U,5)
 S F1=$P(DDGLKEY,U,6)
 S F2=$P(DDGLKEY,U,7)
 S F3=$P(DDGLKEY,U,8)
 S F4=$P(DDGLKEY,U,9)
 S REMOVE=$P(DDGLKEY,U,13)
 S PREVSC=$P(DDGLKEY,U,14)
 S NEXTSC=$P(DDGLKEY,U,15)
 ;
 S DIR0(DIR0P_"IN")="",DIR0(DIR0P_"OUT")=""
 ;
 I DIR0P="C" S I="" F  S I=$O(DIR0MAP(I)) Q:I'=+$P(I,"E")  S T=DIR0MAP(I) D INOUT
 F I=1:1 S T=$P($T(GENMAP+I),";;",2,999) Q:T=""  D INOUT
 I DIR0P="" F I=1:1 S T=$P($T(SMMAP+I),";;",2,999) Q:T=""  D INOUT
 ;
 S DIR0(DIR0P_"IN")=DIR0(DIR0P_"IN")_U
 S DIR0(DIR0P_"OUT")=$E(DIR0(DIR0P_"OUT"),1,$L(DIR0(DIR0P_"OUT"))-1)
 Q
 ;
INOUT ;Set DIR0("IN") and DIR0("OUT")
 I $P(T,";",2)="KEYDOWN" Q:$P(T,";")=""  S DIR0KD=$P(T,";"),K="KD"
 E  I $P(T,";",2)="TIMEOUT" Q:$P(T,";")=""  S DIR0TO=$P(T,";"),K="TO"
 E  S @("K="_$P(T,";",2))
 I DIR0(DIR0P_"IN")'[(U_K) D
 . S DIR0(DIR0P_"IN")=DIR0(DIR0P_"IN")_U_K
 . S DIR0(DIR0P_"OUT")=DIR0(DIR0P_"OUT")_$P(T,";")_";"
 ;
 Q
GENMAP ;General field editor key sequences
 ;;RIGHT;AR
 ;;LEFT;AL
 ;;JRT;F1_AR
 ;;JLT;F1_AL
 ;;FDE;F1_F1_AR
 ;;FDB;F1_F1_AL
 ;;WRT;F1_" "
 ;;WRT;$C(12)
 ;;WLT;$C(10)
 ;;DEL;REMOVE
 ;;DEL;F2
 ;;CLR;F1_"D"
 ;;CLR;$C(21)
 ;;DEOF;F1_F2
 ;;DLW;$C(23)
 ;;CR;$C(13)
 ;;UP;AU
 ;;DOWN;AD
 ;;TAB;$C(9)
 ;;RPM;F3
 ;;BS;$C(127)
 ;;BS;$C(8)
 ;;
SMMAP ;ScreenMan specific key sequences
 ;;FDL;F4
 ;;NB;F1_F4
 ;;NP;F1_AD
 ;;NP;NEXTSC
 ;;PP;F1_AU
 ;;PP;PREVSC
 ;;HLP;F1_"H"
 ;;SEL;F1_"L"
 ;;EX;F1_"E"
 ;;QT;F1_"Q"
 ;;CL;F1_"C"
 ;;SV;F1_"S"
 ;;RF;F1_"R"
 ;;ZM;F1_"Z"
 ;;

DIR0W
DIR0W ;SFISC/MKO-WORD FUNCTIONS FOR FIELD EDITOR ;09:45 AM  12 Dec 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
WRT N DIR0I
 Q:DIR0C>$L(DIR0A)
 S DIR0I=$$WRPOS(DIR0A)
 ;
 I DIR0C-DX+DIR0S+DIR0L>DIR0I S DX=DX+DIR0I-DIR0C,DIR0C=DIR0I Q
 S DIR0C=DIR0I,DX=DIR0S X IOXY
 I $L(DIR0A)-DIR0L<DIR0C D
 . W $E(DIR0A,$L(DIR0A)-DIR0L+1,$L(DIR0A))
 . S DX=DIR0S+DIR0C-$L(DIR0A)+DIR0L-1
 E  W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
 Q
 ;
WLT N DIR0D,DIR0I,DIR0T
 Q:DIR0C=1
 S DIR0T=$$PUNC(DIR0A)
 ;
 S DIR0I=DIR0C-1
 I $E(DIR0T,DIR0I)=" " F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'=" "
 I $E(DIR0T,DIR0I)="!" D
 . F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'="!"
 E  I DIR0I D
 . F DIR0I=DIR0I-1:-1:0 Q:" !"[$E(DIR0T,DIR0I)
 S DIR0I=DIR0I+1
 ;
 I DIR0C-DX+DIR0S'>DIR0I S DX=DX-DIR0C+DIR0I,DIR0C=DIR0I Q
 S DIR0C=DIR0I,DX=DIR0S X IOXY
 I DIR0L'<DIR0C W $E(DIR0A,1,DIR0L) S DX=DIR0S+DIR0C-1 Q
 S DX=DIR0L*2\3+DIR0S W $E(DIR0A,DIR0C-DX+DIR0S,DIR0C+DIR0F-DX-1)
 Q
 ;
DLW N DIR0I,DIR0X
 Q:DIR0C>$L(DIR0A)
 S DIR0CHG=1
 ;
 S DIR0I=$$WRPOS(DIR0A)
 S $E(DIR0A,DIR0C,DIR0I-1)=""
 ;
 S DIR0X=DIR0L\3+DIR0S
 I DX>DIR0X,$L($E(DIR0A,DIR0C,$L(DIR0A)))+DIR0X>DIR0F D
 . S DX=DIR0S X IOXY
 . W $E(DIR0A,DIR0C-DIR0X+DIR0S,DIR0C+DIR0F-DIR0X-1)
 . S DX=DIR0X
 E  D
 . S DIR0X=$E(DIR0A,DIR0C,DIR0C+DIR0F-DX-1)
 . S DIR0X=DIR0X_$J("",DIR0F-DX-$L(DIR0X))
 . W DIR0X
 Q
 ;
WRT2 Q:DIR0C>$L(DIR0A)
 S DIR0C=$$WRPOS(DIR0A)
 ;
 I DIR0C>$L(DIR0A) S DIR0C=0 D FDE^DIR03 Q
 S DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
 S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
 S DY=DIR0R+DIR0LN-1
 Q
 ;
WLT2 N DIR0D,DIR0I,DIR0T
 Q:DIR0C=1
 S DIR0T=$$PUNC(DIR0A)
 ;
 S DIR0I=DIR0C-1
 I $E(DIR0T,DIR0I)=" " F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'=" "
 I $E(DIR0T,DIR0I)="!" D
 . F DIR0I=DIR0I-1:-1:0 Q:$E(DIR0T,DIR0I)'="!"
 E  I DIR0I D
 . F DIR0I=DIR0I-1:-1:0 Q:" !"[$E(DIR0T,DIR0I)
 S DIR0I=DIR0I+1
 ;
 I DIR0I=1 D FDB^DIR03 Q
 S DIR0C=DIR0I,DIR0LN=DIR0C-1\DIR0L+1,DX=DIR0C-1#DIR0L+DIR0S
 S:DIR0LN>DIR0NL DIR0LN=DIR0NL,DX=DIR0S+DIR0NC
 S DY=DIR0R+DIR0LN-1
 Q
 ;
DLW2 N DIR0I,DIR0X
 Q:DIR0C>$L(DIR0A)
 S DIR0CHG=1
 ;
 S DIR0I=$$WRPOS(DIR0A)
 S $E(DIR0A,DIR0C,DIR0I-1)=""
 ;
 S DIR0X=DIR0A_$J("",DIR0I-DIR0C)
 W $E(DIR0X,DIR0C,DIR0C+DIR0F-DX)
 D
 . N DY,DX
 . S DX=DIR0S
 . F DIR0I=DIR0C\DIR0L+2:1:$L(DIR0X)\DIR0L+1 D
 .. S DY=DIR0R+DIR0I-1 X IOXY
 .. W $E(DIR0X,DIR0I-1*DIR0L+1,DIR0I*DIR0L)
 Q
 ;
WRPOS(DIR0T) ;
 N DIR0I,DIR0P,DIR0S
 S DIR0T=$$PUNC(DIR0T)
 S DIR0S=$F(DIR0T," ",DIR0C+1),DIR0P=$F(DIR0T,"!",DIR0C+1)
 S:'DIR0S DIR0S=999 S:'DIR0P DIR0P=999
 ;
 I DIR0S=999,DIR0P=999 D
 . S DIR0I=$L(DIR0T)+1
 E  I $E(DIR0T,DIR0C)="!" D
 . F DIR0I=DIR0C+1:1 Q:$E(DIR0T,DIR0I)'="!"
 . F DIR0I=DIR0I:1 Q:$E(DIR0T,DIR0I)'=" "
 E  I DIR0S<DIR0P D
 . F DIR0I=DIR0S:1 Q:$E(DIR0T,DIR0I)'=" "
 E  S DIR0I=DIR0P-1
 Q DIR0I
 ;
PUNC(X) ;
 Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!"))

DIR1
DIR1 ;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;9/10/96  14:24
 ;;21.0;VA FileMan;**6,13,19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %E=0 D @%T I '%E!(X?.UNP)!(%A["S")!(%A["Y") Q
 F %Y=1:1:$L(X) I $E(X,%Y)?1L S X=$E(X,1,%Y-1)_$C($A(X,%Y)-32)_$E(X,%Y+1,999)
 G DIR1
Y ; YES/NO
S ; SET
 N %BU,%K,%M,%J,DDH
 I $L(X)>245 S %E=1 Q
 I %T="S",$D(DIR("S"))#2 S DIC("S")=DIR("S")
 S %BA=$S($D(DIC("S")):DIC("S"),1:"I 1")
 S (%J,%K,DDH)=0,Y(0)=$P($P(";"_%B,";"_X_":",2),";") I Y(0)]"" S Y=X X %BA I  S %J=1
 I '%J F %I=1:1 S %J=$P(%B,";",%I) Q:%J=""  S Y=$F(%J,":"_X) I Y S Y=$P(%J,":") X %BA I  S %K=%K+1,%K(%K)=%J Q:%A["o"
 I %J="",%A'["X",'%K D
 . S %BU=$$UP^DILIBF(%B),%M=X N X S X=$$UP^DILIBF(%M)
 . F %I=1:1 S %J=$P(%BU,";",%I),%J1=$P(%B,";",%I) Q:%J=""  S Y=$F(%J,":"_X) I Y S Y=$P(%J1,":") X %BA I  S %K=%K+1,%K(%K)=%J1 Q:%A["o"
 I %K=1 S Y=$P(%K(1),":"),Y(0)=$P(%K(1),":",2)
 I %K>1,$G(DIQUIET) S %E=1 Q
 I %K>1 D CH Q:%E=1  I '$D(%K(%I)) S X=%I G S
 I %J="",'%K S %E=1 Q
 I %A'["V",$D(DDS)[0 W $S((%K=1!('%K))&($P(Y(0),X)=""):$E(Y(0),$L(X)+1,99),1:"  "_Y(0))
 I %T="Y" S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%<0 (%,Y)="" S:%=2 Y=0
 Q
 ;
CH ;
 N DIY,DDD,DDC,DS,DD
 F %I=1:1:%K S A0="     "_%I_"   "_$P(%K(%I),":",2) D MSG
 I '$D(DDS) S A0="Choose 1-"_%K_": " D MSG R %I:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME)
 I $D(DDS) S DDD=2,DDC=5,(DS,DD)=%K D LIST^DDSU S %I=DIY
 I U[%I!(%I?1."?") S X="?",%E=1 Q
 I $D(%K(%I)) S Y=$P(%K(%I),":"),Y(0)=$P(%K(%I),":",2)
 Q
 ;
MSG ;
 I $D(DDS),A0]"" S DDH=$G(DDH)+1,DS(DDH)=$P(%K(%I),":"),DDH(DDH,DDH)=$P(%K(%I),":",2)
 I '$D(DDS) W !,A0
 K A0
 Q
 ;
L ; LIST OR RANGE
 D L^DIR3
 Q
D ; DATE
 D ^%DT I Y<0 S %E=1 Q
 I %D1["NOW"!(%D2["NOW")&($P("NOW",$$UP^DILIBF(X))="") S:%D1["NOW" %B1=Y S:%D2["NOW" %B2=Y
 I %B1,Y<%B1 S %E=1 S:'%N %W="Response must not be previous to "_+$E(%B1,4,5)_"/"_+$E(%B1,6,7)_"/"_$E(%B1,2,3) Q
 I Y>%B2 S %E=1 S:'%N %W="Response must not be following "_+$E(%B2,4,5)_"/"_+$E(%B2,6,7)_"/"_$E(%B2,2,3)
 S Y(1)=Y X ^DD("DD") S Y(0)=Y,Y=Y(1) K Y(1)
 Q
 ;
N ; NUMERIC
 I $L($P(X,"."))>24 S %E=1 Q
 I X'?.1"-".N.1".".N S %E=1 Q
 I X>%B2!(X<%B1) S %E=1 S:'%N %W="Response must be no "_$S(X>%B2:"greater",1:"less")_" than "_$S(X>%B2:%B2,1:+%B1) Q
 I '%E,($L($P(+X,".",2))>%B3) S %E=1 S:'%N %W="Response must be with no more than "_+%B3_" decimal digit"_$S(%B3>1:"s",1:"") Q
 S Y=+X
 Q
 ;
F ; FREETEXT
 S Y=X I X[U,%A'["U" S %E=1
 S:'%N %W="This response must have at least "_+%B1_" character"_$S(+%B1>1:"s",1:"")_" and no more than "_%B2_" characters"_$S(%A'["U":" and must not contain embedded uparrow",1:"")
 I $L(X)<%B1!($L(X)>%B2) S %E=1
 Q
 ;
E ; END-OF-PAGE
 S Y=X="" S:X=U (DUOUT,DIRUT)=1 I $L(X),X'=U S %E=1
 Q
 ;
P ; POINTER
 S:'$D(DDS) %B2=$P(%B2,"L")_$P(%B2,"L",2)
 I %B2["A" S %B2=$P(%B2,"A")_$P(%B2,"A",2)
 S:$D(DIR("S"))#2 DIC("S")=DIR("S")
 S DIC=%B1,DIC(0)=%B2,%C=X D P1
 I $D(X)#2,X="",Y<0 S %E=-1
 E  S %E=Y<0
 S X=%C
 Q
P1 N %A,%B,%C,%N,%P,%T,%W D ^DIC
 Q
 ;
1 ; DD
 S %C=X N %W I %B["P"!(%B["V") N DIE
 I %B["F" S Y=X I X[U,$P($P(%B3,U,4),";",2)'?1"E"1.N1","1.N S %E=1 Q
 I %B["S" S %B=$P(%B3,U,3),%BU=$$UP^DILIBF(%B) X:$D(^DD(%B1,%B2,12.1)) ^(12.1) D S S X=Y,%B=$P(%B3,U,2) G R
 I %B["P" S DIC=U_$P(%B3,U,3),DIE=DIC,DIC(0)=$E("L",%B'["'"&$D(DDS))_$E("E",$D(DIR("V"))[0)_"MZ" I %B'["*" D P1 S X=+Y,%E=Y<0
 I %B["V" D
 . N %A,%B,%C,%N,%P,%T,%W
 . S (DIE,DP)=%B1,DIFLD=%B2,DQ=1
 . D ^DIE3
 . S %E=Y'>0 S:Y>0 Y(0)=$P(Y,U,2)
R D IT:'%E S X=%C
 Q
IT D
 . N %A,%B,%C,%N,%P,%T,%W
 . I $P(%B3,U,2)["N",$P(%B3,U,5,99)'["$",X?.1"-".N.1".".N,$P(%B3,U,5,99)["+X'=X" S X=+X
 . X $P(%B3,U,5,99)
 S %E='$D(X)
 I '%E,%B'["P" S Y=X
 I '%E,%B["D" X ^DD("DD") S Y(0)=Y,Y=X
 Q
 ;
 ;#7001  Yes/No question

DIR2
DIR2 ;SFISC/XAK-READER (SETUP VARS,REPLACE...WITH) ;8/26/94  08:58
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; Check that the inputs to the reader are there and setup variables
 K Y,% S U="^"
 S %T=$E(DIR(0)),%A=$P(DIR(0),U),%B=$P(DIR(0),U,2),%N=%A'["V"
 K:$D(DIR("A"))=10 DIR("A") K:$D(DIR("?"))=10 DIR("?")
 S %W0=$S($D(DIR("?")):DIR("?"),%T'?.AN:"",'$P($T(@(%T_1)),";",5):"",1:$$EZBLD^DIALOG($P($T(@(%T_1)),";",5))),%A0=$$EZBLD^DIALOG(8041)
 I %A?.NP1",".ANP S %B1=$P(%A,","),%B2=+$P(%A,",",2) G:'$D(^DD(%B1,%B2,0)) EO S %B3=^(0),%B=$P(%B3,U,2) G:%B EO D:'$D(DIR("B")) DA^DIRQ:$D(DA)#2 S:'$D(DIR("A")) %P=$P(%B3,U)_": " S:$P(%B3,U,2)'["R" %A=%A_"O" S %T=1 G NN
 I "FSYENDLP"'[%T G EO
 S %B1=$P(%B,":"),%B2=$P(%B,":",2),%B3=$P(%B,":",3)
 S:'$L(%B2) %B2=999999999999 I %T="F",%B2>245 S %B2=245
 I %T="Y" S %B=$$EZBLD^DIALOG(7003)
 I %T="D" S %DT=$P(%B3,"A")_$P(%B3,"A",2)
 I %T="D" S %D1=%B1,%D2=%B2 I %B["NOW"!(%B["DT") D NOW^%DTC K %I,%H S DT=X S:%B1["NOW" %B1=% S:%B1["DT" %B1=X S:%B2["NOW" %B2=% S:%B2["DT" %B2=X K %
 I %T="P" S %B1=$S('%B1:U_%B1,'$D(^DIC(+%B1,0,"GL")):U,1:^("GL")) G EO:%B1=U,EO:'$D(@(%B1_"0)")) I '$D(DIR("A")) S %P=$$EZBLD^DIALOG(8042,$O(^DD(+$P(^(0),U,2),0,"NM",0))) Q
NN D:%T="S" S0:%A'["A" Q:$D(%P)
 S %P="" I %A["A" S:$D(DIR("A")) %P=DIR("A") Q
 I '$D(DIR("A")) S %P=$$EZBLD^DIALOG($P($T(@%T),";",4)) I %T="D" S %P=%P_$S(%B3["R":$$EZBLD^DIALOG(8043),%B3["T":$$EZBLD^DIALOG(8044),1:"")
 S:$D(DIR("A")) %P=$S(%T="Y":DIR("A")_"? ",%T="S":$$EZBLD^DIALOG(8045,DIR("A")),1:DIR("A")_": ") I "LND"'[%T Q
 I $L(%B1) S %P=%P_" ("_$S(%T="D":+$E(%B1,4,5)_"/"_+$E(%B1,6,7)_"/"_$E(%B1,2,3)_" - "_+$E(%B2,4,5)_"/"_+$E(%B2,6,7)_"/"_$E(%B2,2,3),1:%B1_"-"_%B2)_")"
 S %P=%P_$S("?: "[$E(%P,$L(%P)):"",1:":")_" "
 Q
S0 S %P=$S($D(DIR("A")):DIR("A")_": ",%A["B":$$EZBLD^DIALOG(8046),1:$$EZBLD^DIALOG($P($T(@%T),";",4)))
 Q:%A'["B"  S %P=%P_" ("
 F %I=1:1 Q:$P(%B,";",%I,999)=""  D
 . N Y S Y=$P($P(%B,";",%I),":") Q:Y=""
 . I $D(DIR("S"))#2 X DIR("S") E  Q
 . S %P=%P_Y_"/"
 S %P=$E(%P,1,$L(%P)-(%P?.E1"/"))_"): "
 Q
EO S %T="",Y=-1 Q
 ;
RW ; Replace...With...
 N %,L S DG=Y S:$D(DTIME)[0 DTIME=999
A W:$X>50 ! K DTOUT W $$EZBLD^DIALOG(8047) R X:DTIME E  S DTOUT=1,X=""
 G B:X="",Q:X?1."^",Q:$E(X)=U&($D(DIRWP)[0)&(Y'[X),Q:X?."?",Q:X="@",E2:X="END"!(X="end")
 I Y[X S D=X,L=$L(X) D H S:'%&'$D(DTOUT) Y=$P(Y,D,1)_X_$P(Y,D,2,999) G A
 S D=$P(X,"...",1),DH=$F(Y,D) I DH S X=$P(X,"...",2,99),X=$S(X="":$L(Y)+1,1:$F(Y,X,DH)) I X S DH=DH-$L(D)-1,D=X,L=D-DH-1 D H S:'%&'$D(DTOUT) Y=$E(Y,1,DH)_X_$E(Y,D,999) G A
 W $C(7)," ??" G A
H W $$EZBLD^DIALOG(8048) R X:DTIME E  S DTOUT=1,X="",%=0 W $C(7)," ??" Q
 S %=$L(Y)-L+$L(X)>245 I % W $C(7),$S($L(Y)-L'>245:$$EZBLD^DIALOG(349,($L(Y)-L+$L(X)-245)),X'=U:$$EZBLD^DIALOG(350),1:" ??") Q:$L(Y)-L>245&(X=U)  G H
 Q:X?.ANP  W $C(7)," ??" G H
E2 S L=0 D H S:'%&'$D(DTOUT) Y=Y_X G A
B W:$D(DTOUT) *7 I DG'=Y S X=Y W !?3 W X I X="" S X="@"
Q Q
 ;
F ;;Enter response: ;8051
S ;;Enter response: ;8051
Y ;;Enter Yes or No: ;8052
E ;;Press RETURN to continue or '^' to exit: ;8053
N ;;Enter a number;8054
D ;;Enter a date;8055
L ;;Enter a list or range of numbers;8056
P ;;Select: ;8057
F1 ;;;This response can be free text;9031
S1 ;;;Enter a code from the list.;9032
Y1 ;;;Enter either 'Y' or 'N'.;9040
E1 ;;;Enter either RETURN or '^';9033
N1 ;;;This response must be a number;9034
D1 ;;;This response must be a date;9035
L1 ;;;This response must be a list or range, e.g., 1,3,5 or 2-4,8;9036
 ;
 ;#349   String too long by |nuber| character(s)!
 ;#350   String too long! '^' to quit.
 ;#8041  This is a required response...
 ;#8042  Select |1|
 ;#8043  and time
 ;#8044  and optimal time
 ;#8045  Enter |1|
 ;#8046  Select one of the following
 ;#8047  Replace
 ;#8048  With

DIR3
DIR3 ;SFISC/DCM,RDS-READER-MAID (PROCESS RANGE/LIST);3/15/96  09:41
 ;;21.0;VA FileMan;**19**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
L ; LIST OR RANGE
 N %I,%I1,%I2,%BA,%X,%C,%1,%2,%3,%4,%
 K ^TMP($J,"DIR")
 S Y(0)="",%C=0,%I1=1,%I2=2,%BA=$S($D(DIR("S")):DIR("S"),1:"I 1")
 F %I=1:1 S %X=$P(X,",",%I) Q:%E!'$L($P(X,",",%I,999))  D
 .I %X'?.".".N.".".N."-".N.".".N S %E=4 Q
 .I $E(%X)="-" S %E=3 Q
 .I $L($P(%X,"."))>24 S %E=1 Q
 .I '%B3,$L($P(+%X,".",2)) S %E=2
 I '%E D @$S(%A["C"&'$D(DIR("S")):"LC",%A["C"&$D(DIR("S")):"LL",1:"LL")
 I '%E,Y(%C)="" S %E=4
 I $G(%E),'%N D
 .S %W=$P($T(@(%E)),";;",2)
 .I %W[";",%E=1 S %W=$P(%W,";")_+%B1_$P(%W,";",2)_" "_%B2
 .I %W[";",%E=2 S %W=$P(%W,";")_+%B3_$P(%W,";",2)_$S(%B3>1:"s",1:"")
 S Y=Y(0)
 Q
 ;
LL I %B3 D LCD
 F %I=1:1 S %X=$P(X,",",%I) Q:%E!'$L($P(X,",",%I,999))  D L0
 Q:%E
 I %A["C" D LIST
 Q
L0 N %J
 D LCK
 Q:%E  I %X?.N!(%X?1N.".".N) S %J=+%X G L1
 I %B3 D  Q
 .S %J=+%X D L1 S $P(%X,"-")=%X+%I1
 .F %J=+%X:%I1:$P(%X,"-",2) D L1
 F %J=$P(%X,"-"):1:$P(%X,"-",2) D L1
 Q
L1 I %A["C" D  Q
 .S Y=%J X %BA Q:'$T
 .S (%1,%2)=%J
 .D LC1
 I $L(Y(%C)_%J)>220 S %C=%C+1,Y(%C)=""
 F %=0:1:%C I ","_Y(%)_","[(","_%J_",") S %=-1 Q
 I %'<0 S Y=%J X %BA S:$T Y(%C)=Y(%C)_%J_","
 Q
 ;
LCK I %X["-" D  Q
 .N % S %=$P(%X,"-",2) I '% S %E=4 Q
 .I %<+%X S %E=4 Q
 .I %<%B1!(+%X>%B2) S %E=1 Q
 .I +%X<%B1 S $P(%X,"-")=%B1
 .I +%>%B2 S $P(%X,"-",2)=%B2
 .Q:'%B3
 .I $L($P(+%X,".",2))>%B3!($L($P(+%,".",2))>%B3) S %E=2 Q
 I +%X<%B1!(+%X>%B2) S %E=1 Q
 I %B3,$L($P(+%X,".",2))>%B3 S %E=2 Q
 Q
 ;
LCD ;
 S %1="." I %B3>1 F %=1:1:%B3-1 S %1=%1_"0"
 S %I2=%1_2,%I1=%1_1
 Q
 ;
LC I %B3 D LCD
 F %=1:1:$L(X,",") S %1=$P(X,",",%) D LC0
 Q:'$D(^TMP($J,"DIR"))
 S %E=0
LIST S %1="",Y(%C)="" D 
 .F  S %1=$O(^TMP($J,"DIR",%1)),%2="" Q:%1=""  D
 ..S:$D(^(%1))=1 Y(%C)=Y(%C)_%1_","
 ..S:$L(Y(%C))>220 %C=%C+1,Y(%C)=""
 ..I $D(^(%1))=10 F  S %2=$O(^TMP($J,"DIR",%1,%2)) Q:%2=""  S Y(%C)=Y(%C)_%2_"-"_%1_","
 I Y(%C)="" S %E=4 Q
 K ^TMP($J,"DIR")
 Q
LC0 S %E=0,%X=%1 D LCK Q:%E  S (%1,%2)=%X
 I %1["-" S %1=+%1,%2=+$P(%2,"-",2)
 I %1>%2 S %3=%1,%1=%2,%2=%3
 S %1=+%1,%2=+%2
 D LC1
 Q
LC1 S %3=$O(^TMP($J,"DIR",%1-%I2)) I %3]"",%3<%2 S:$D(^(%3))=1&(%1-%I1=%3) %1=%3 I $D(^(%3))>9 S %4=$O(^(%3,"")) I %4<%1 S %1=%4
 S %3=$O(^TMP($J,"DIR",%2-$S(%B3:%I1,1:1))) I %3]"" S:$D(^(%3))=1&(%2+%I1=%3) %2=%3 I $D(^(%3))>9 S %4=$O(^(%3,"")) I %4'>(%2+%I1) S %2=%3
 S %3=%1-%I1 F  S %3=$O(^TMP($J,"DIR",%3)) Q:%3=""!(%3>%2)  D:%3=%2  Q:%3=%2  K ^TMP($J,"DIR",%3)
 .Q:$D(^TMP($J,"DIR",%3))=1  S %4=$O(^(%3,""))
 .I %4>%1 K ^TMP($J,"DIR",%3)
 .I %4<%1 S %1=%4
 S:%1'=%2 ^TMP($J,"DIR",%2,%1)="" S:%1=%2 ^TMP($J,"DIR",%1)="" Q
 ;
1 ;;Response should be no less than ; and no greater than
2 ;;Response must be no more than ; decimal digit
3 ;;Response must be a positive number
4 ;;Invalid number or range

DIRCR
DIRCR ;SFISC/GFT-DELETE THIS LINE AND SAVE AS '%RCR'*** ;12:18 PM  20 Apr 1993 [ 02/24/95  7:42 AM ]
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
%RCR ;GFT/SF
 ;
STORLIST ;
 ; begin IHS mods
 S %D="" F  S %D=$O(%RCR(%D)) Q:%D=""  ZNEW @%D  ;IHS/MFD added line
 S %E=%RCR K %RCR,%X,%Y D @%E Q  ;IHS/MFD added line
 ; end IHS mods
 D INIT
O S %D=$O(%RCR(%D)) G CALL:%D=""
 I $D(@%D)#2 S @(%E_")="_%D) G O:$D(@%D)=1
 S %X=%D_"(" D %XY G O
 ;
CALL S %E=%RCR K %RCR,%X,%Y D @%E
 S %E="^UTILITY(""%RCR"",$J,"_^UTILITY("%RCR",$J)_",%D",^($J)=^($J)-1,%D=0,%X=%E_","
G S %D=$O(@(%E_")")) I %D="" K %D,%E,%X,%Y,^($J,^UTILITY("%RCR",$J)+1) Q
 I $D(^(%D))#2 S @%D=^(%D) G G:$D(^(%D))=1
 S %Y=%D_"(" D %XY G G
 ;
 ;
XY(%X,%Y) ;
%XY ;
 N %A,%B,%Q,%Z
 S %A=$$R(%X),%Q=""""""
 I $P(%A,"(",2)]"",$E(%A,$L(%A))'="," S:$L($P(%A,"(",2),",")>1 %Q=$P(%A,",",$L(%A,",")),$P(%A,",",$L(%A,","))="" S:%Q="""""" %Q=$P(%A,"(",2),$P(%A,"(",2)=""
 S %Z=%A_%Q_")",%B=$L(%A)+1
 F  S %Z=$Q(@%Z) Q:$P(%Z,%A)]""!(%Z="")  S @(%Y_$E(%Z,%B,255))=@%Z
 Q
R(%R) ;
 N %C,%F,%G,%I,%R1,%R2
 S %R1=$P(%R,"(")_"(" I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
 S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
 S %C=$L(%R2,","),%F=1 F %I=1:1:%C S %G=$P(%R2,",",%F,%I) Q:%G=""  I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1
 Q %R1_%R2
S(%Z) ;
 I $G(%Z)']"" Q ""
 I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
 I +%Z=%Z Q %Z
 I %Z="""""" Q ""
 I $E(%Z)'?1A,"%$+@"'[$E(%Z) Q %Z
 I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
 I $D(@%Z) Q $$Q(@%Z)
 Q %Z
Q(%Z) ;
 S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
 ;
INIT I $D(^UTILITY("%RCR",$J))[0 S ^UTILITY("%RCR",$J)=0
 S ^($J)=^($J)+1,%D="%Z",%E="^UTILITY(""%RCR"",$J,"_^($J)_",%D",%Y=%E_","
 K ^($J,^($J))
 Q
OS ;
 S $P(^%ZOSF("OS"),"^",2)=DITZS
 K DITZS S ZTREQ="@"
 Q

DIRQ
DIRQ ;SFISC/XAK-READER-MAID END ;7/11/94  14:34
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K:$D(%G) DIR("B")
 K DIR0("L")
 Q
DA I DA'=+$P(DA,"E") K DA Q
 S (X,Y)=%B1,DA(0)=DA
 F %=0:1 Q:'$D(^DD(X,0,"UP"))  S X=^("UP"),%P=$O(^DD(X,"SB",Y,0)),%(%)=""""_$P($P(^DD(X,%P,0),U,4),";")_""",",Y=X
 S %(%)=$S($D(^DIC(X,0,"GL")):^("GL"),1:"") G Q:%(%)=""
 S %G="" F %=%:-1:0 G GQ:'$D(DA(%)) S %G=%G_%(%)_DA(%)_","
 S %P=$P(%B3,U,4),%=$P(%P,";"),%G=%G_""""_%_""")" G GQ:'$D(@%G)
 S %G=$P(%P,";",2),Y=$S(%G:$P(^(%),U,%G),1:$E(^(%),+$P(%G,"E",2),$P(%G,",",2))) G GQ:Y=""
 S %G=Y,C=$P(^DD(%B1,%B2,0),U,2) D Y^DIQ S DIR("B")=Y G Q
GQ K %G
Q K %,%P,X,Y,DA(0) Q

DIS
DIS ;SFISC/GFT-GATHER SEARCH CRITERIA ;9/30/94  15:57
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K ^UTILITY($J),DC,DIS,%ZIS,O,N,R D ^DICRW
 G Q:'$D(DIC)!$D(DTOUT)
EN ;
 S:DIC DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"") Q:DIC=""
 K DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J) G Q:'$D(@(DIC_"0)"))
 S (R,DI,I(0))=DIC,(DL,DC)=1,DY=999,N=0,Q="""",DV="" D DL
R ;
 I +R=R S (J(N),DK)=R,R=""
 E  S @("(J(N),DK)=+$P("_R_"0),U,2)"),R=$P(^(0),U)
F ;
 W ! K X,DIC,P D W S DIC(0)="EZ",C=",",DIC="^DD("_DK_C,DIC("W")="S %=$P(^(0),U,2) W:% $S($P(^DD(+%,.01,0),U,2)[""W"":""   (word-processing)"",1:""   (multiple)"")",DIC("S")="I $P(^(0),U,2)'[""m"""_$S($D(DICS):" "_DICS,1:""),DU=""
 W "SEARCH FOR "_R_" "_$P(^DD(DK,0),U,1)_": "
 R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T,TEM^DIS2:X?1"[".E D  I Y>0 K P S DE=Y(0),O(DC)=$P(DE,U,1),DU=+Y,Z=$P(DE,U,3),E=$P(DE,U,2) G G
 .N DISVX S DISVX=X D ^DIC S:Y=-1 X=DISVX Q
HARD G UP:X="",F:X?."?",Q:X=U!($D(DTOUT)),COMP^DIS2
DL ;S DL=$S('$D(DIARF0):DL,1:DIARF1+DL)
 Q
G ;
 K X,DIC S DIC="^DOPT(""DIS"",",DIC(0)="QEZ" I E["B" S X="" G OK
 I E S N(DL)=N,N=N+1,DV(DL)=DV,DL(DL)=DK,DK=+E,J(N)=DK,X=$P($P(DE,U,4),";",1),I(N)=$S(+X=X:X,1:Q_X_Q),Y(0)=^DD(DK,.01,0),DL=DL+1 G WP:$P(Y(0),U,2)["W" S DV=DV_+Y_C G F
 I E["P" S P=+Y_U_Y(0),X="#"_+Y_":.01" G HARD
C D W R "CONDITION: ",X:DTIME S:'$T DTOUT=1 G Q:X[U!'$T
 S DN=$S("'-"[$E(X):"'",1:""),X=$E(X,DN]""+1,99) D ^DIC
 G:Y<0 Q:X[U,B:X="",DISC^DIQQQ:X["?",C
 S O=$P("NOT ",U,DN]"")_$P(Y,U,2)
 I +Y=1 S X=DN_"?."" """,O(DC)=O(DC)_" "_O G OK
 S DQ=Y D W W O I E["D",Y-3 R " DATE: ",X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S %DT="TE" D ^%DT S X=Y_U_X G X:Y<0 X ^DD("DD") S Y=X_U_Y G GOT
 ;POINTERS
PT I $D(P),+DQ=5 K DIC,DIS($C(DC+64)_DL) S DIC=U_$P(P,U,4),DIC(0)="EMQ",DU=+P W " "_$P(@(DIC_"0)"),U,1)_": " R X:DTIME S:'$T DTOUT=1 G Q:U[X!'$T D ^DIC G GOT:Y>0,PT
 R ": ",Y:DTIME I '$T S DTOUT=1 G Q
 G X:Y="" I Y[U,$P(DE,U,4)'[";E" G X
 I +DQ=3 S X="I X?"_Y D ^DIM G GOT:$D(X) S Y="?"
 G DIS^DIQQQ:Y?."?",T:E'["S",N:+DQ'=5 S Y=":"_Y
 ;SET OF CODES
 F X=1:1 S D=$P(Z,";",X) Q:D=""  I D[Y W $P(D,Y,2) S Y=$P(D,":")_U_$P(D,":",2) G T
 S %="",Y="""" W $C(7),!,"[ Enter EXTERNAL VALUE for one of the following: ",!
 G O
N S %="[ WILL APPLY TO:" W $C(7),!?7
O F X=1:1 S D=$P(Z,";",X),DE=$P(D,":",2) Q:D=""  W % W:X>1 "," W " " S %="'"_$P(D,":")_"' ("_DE_")",DIS(U,DC,$P(D,":",1))=DE W:$X+$L(%)>73 !?7
 W:X>2 "AND " W %_" ]"
 I +DQ=5,$P(Y,U)[Q K DIS(U,DC)
T I DQ["THAN",+$P(Y,U)'=$P(Y,U) G X
 I DQ#3=2 G X:$P(Y,U)[Q I +$P(Y,U)'=$P(Y,U) S $P(Y,U)=Q_$P(Y,U)_Q
GOT S X=DN_$E(" [?<=>",DQ)_$P(Y,U) I E["D" S Y=$P(Y,U,3)_U_$P(Y,U,2)
 S O(DC)=O(DC)_" "_O_" "_Y
OK S DC(DC)=DV_DU_U_X_U_$P(Y,U,2),%=DL-1_U_(N#100)
 I DL>1,O(DC)'[R S O(DC)=R_" "_O(DC)
 S:DU["W" %=DL-2_U_(N#100-1) S DX(DC)=%,DC=DC+1
B G F:DU'["W"
UP I DC>1 G ^DIS0:DL<$S('$D(DIARF0):2,1:2) S DL=DL-1,DV=DV(DL),DK=DL(DL),N=N(DL),R=$S($D(R(DL)):R(DL),1:R) K R(DL) S %=N F  S %=$O(I(%)) S:%="" %=-1 G F:%<0 K I(%),J(%)
Q G Q^DIS2:'$D(DIARU),^DIS2
 ;
WP S DIC("S")="I Y<3",DU=+Y_"W" G C
 ;
X ;
 W $C(7),"??",!! G B
 ;
W W !?DL*2,"-"_$C(DC+64)_"- " Q
ENS ; ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE
 G EN^DIS3

DIS0
DIS0 ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;2/24/93  13:51 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W ! K R,N,DL,DE,DJ
 S O=0,E=$D(DC(2)),N="IF: A// ",DE=$S(E:"IF: ",1:N),DL=0
 S C=","
R W !,DE K DV R X:DTIME S:'$T DTOUT=1 G Q:X[U!'$T
 I X="" S DV=1,DU=X G 1:DL S DQ="TYPE '^' TO EXIT",Y="^1^",DL=1 G BAD:E D ASKQ G L
 S Y=U,P=0,DU="",D="",DL=DL+1
P S P=P+1,DQ=$E(X,P) I DQ="" G BAD:Y=U,L
 I DQ?.A S DV=$A(DQ)-64 I $D(DC(DV)) D ASKQ G CHK
 G P:"&+ "[DQ I DU="","'-"[DQ S DU="'" G P
BAD W $C(7)," <",DQ,">??" K DJ(DL),DE(DL) S DL=DL-1 G R
 ;
ASKQ S J=DC(DV),%=J["?."" """,I=J["^'"+(DU["'")#2 I J["W^" S DV(DV)=$S(I:2-%,1:%+%+1) S:% DC(DV)=$E(J,1,$L(J)-5)_"=""""" Q
 S:$P(J,U,1)[C DV(DV)=J?.E1",.01^".E&%+(I+%#2) Q
 ;
CHK S %=$F(Y,U_DV) I % S %=$P($E(Y,%),U,1)'=DU,DQ=""""_DQ_""" AND """_$E("'",%)_DQ_""" IS "_$P("REDUNDANT^CONTRADICTORY",U,%+1) G BAD
 S %=1,Y=Y_DV_DU_U,DU="",J=$P(DC(DV),U,1) G P:J'[C F Z=2:1 I $P(J,C,Z,99)'[C S J=$P(J,C,1,Z-1)_C Q
 I J=D D SAMEQ S:%=1 DJ(DL,DV)=DX(DV)
 S D=J,DJ=DV G P:%>0
Q G Q^DIS2
 ;
SAMEQ I J<0,$P(DY(-J),U,3)="" Q
 W !?8,"CONDITION -"_$C(DV+64)_"- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -"_$C(DJ+64)_"-",!?8,"...OK" G YN^DICN
 ;
L S P=O,DL(DL)=Y,DE="OR: " F %=2:1 S X=$P(Y,U,%) Q:X=""  S O=O+1,^UTILITY($J,O,0)=$S(%>2:$S($D(DJ(DL,+X)):"  together with ",1:"   and "),O=1:"",1:" Or ")_$P("not ",U,X["'")_O(+X)
 W:$X>18 ! W "   " F %=P+1:1 Q:'$D(^UTILITY($J,%,0))  S X=^(0) W:$L(X)+$X>77 !?13 W " "_$P(X,U) I $P(X,U,2)'="" W " ("_$P(X,U,2)_")"
 S DV=0
DV S DV=$O(DV(DV)) S:DV="" DV=-1 G:DV'>0 R:E,1 G DV:$D(DJ(DL,DV)) S I=$P(DC(DV),U,1),D=DK,DN=0,Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$C(DV+64)_"-"
G S DN=DN+1,P=$P(I,C,1),I=$P(I,C,2,99) G W:P["W",DV:I="" I P<0 S J=DY(-P),D=+J,R=" '"_$P(^DIC(D,0),U,1)_"' ENTRIES " G G:'$P(J,U,3)
 E  S D=+$P(^DD(D,P,0),U,2),R=" '"_$O(^DD(D,0,"NM",0))_"' MULTIPLES "
HOW W !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT"
 W !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT" S X=2
 I DV(DV) W !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R S X=3
 W !?4,"CHOOSE 1-"_X_": " I DV(DV)>1 W 3 S %1=3
 E  W 1 S %1=1
 R "// ",%:DTIME,! S:'$T DTOUT=1 S:%="" %=%1 K %1 G Q:%=U!'$T,HOW:%>X!'% I %>1 S DE(DL,DV,DN)=%,O=O+1,^UTILITY($J,O,0)="   for all"_R_$P(", or when no"_R_"exist",U,%>2)
 G G
 ;
W I DV(DV)-2 S DE(DL,DV,DN)=DV(DV) G DV
 W !!,Y,!?7,"WHEN THERE IS NO '"_$P(^DD(D,+P,0),U,1)_"' TEXT AT ALL"
 S %=1 D YN^DICN G Q:%<0,W:'% S DE(DL,DV,DN)=4-% G DV
 ;
1 K O,DX,Y G ^DIS1

DIS1
DIS1    ;SFISC/GFT-BUILD DIS-ARRAY ;11/8/94  10:22
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DIS0 I $D(DL)#2 S DIS0=DL
 S DL(0)="" W ! G 1:$D(DE)>1!$D(DJ) I DL=1 S DL(0)=DL(1),DL=0 K DL(1)
 E  F P=2:1 S Y=$P(DL(1),U,P) Q:Y=""  S Y=U_Y_U,X=2 D 2
 F X=1:1 Q:'$D(DL(X))  F Y=X+1:1 Q:'$D(DL(Y))  I DL(X)=DL(Y)!(DL(Y)?.P) S DL=DL-1 K DL(Y) F P=Y:1:DL S DL(P)=DL(P+1) K DL(P+1)
1 D ENT G ^DIS2:'$D(DIAR),DIS^DIS2
 ;
ENT S DK(0)=DK,Z="D0," F DQ=0:1:DL K R,M D  S X=0,DQ(0)=DQ,R=-1 D MAKE S %=0 F  S R=$O(R(R)) Q:R=""  I R(R)<2 S DIS(R)=DIS(R)_" K D"
 . N I S I="" F  S I=$O(DI(I)) Q:'I  K DI(I)
 . Q
 S R=-1 Q
 ;
2 I X'>DL Q:DL(X)'[Y  S X=X+1 G 2
 S DL(0)=U_$P(Y,U,2)_DL(0),P=P-1
22 S X=X-1,DQ=$F(DL(X),Y),DL(X)=$E(DL(X),1,DQ-$L(Y))_$E(DL(X),DQ,999) G 22:X>1 Q
 ;
C S Y=Y_$S(DV="'":" I 'X",1:" I X"_DV) D SD
MAKE S DC=DI,DQ=+DQ,X=X+1,Y=$P(DL(DQ),U,X+1) Q:Y=""
 S S=+Y,DN=$E("'",Y["'"),Y=DC(S),D=0,DL=0 I $D(DJ(DQ,S)) S D=$P(DJ(DQ,S),U,2),DL=+DJ(DQ,S) I $D(DI(DL)) S DC=DI(DL)
 S DQ=DQ(DL),Z=$P(Z,C,1,D+D+1)_C,DU=$P($P(Y,U,1),C,DL+1,99),O=DK(DL),DV=DN_$P(Y,U,2) I DV?1"''".E S DV=$E(DV,3,999)
LEV S DL=DL+1,DN=$S($D(DE(+DQ,X,DL)):DE(+DQ,X,DL),1:1)
 S:$G(DI(DL-1))]"" DI(DL)=DI(DL-1)
 I DU<0 G X:$D(DY(-DU)) S Y=DA(-DU) G C
 S N=$P(^DD(O,+DU,0),U,4),DE=$P(N,";",1),Y=$P(N,";",2) I Y="" S Y="D"_D G M
 I $P(^(0),U,2)["C" S Y=$P(^(0),U,5,99) G C
 S:+DE'=DE DE=""""_DE_""""
 S Z=Z_DE,E="$S($D("_DC_Z_")):$" I Y S Y=E_"P(^("_DE_"),U,"_Y_"),1:"""")" G M
 I Y'=0 S Y=$E(Y,2,99) S:$P(Y,",",2)=+Y Y=+Y S Y=E_"E(^("_DE_"),"_Y_"),1:"""")" G M
 F Y=65:1 S M=DQ_$C(Y) Q:'$D(DIS(M))
 S D=D+1,Y="S D"_D_"=+$O("_DC_Z_",0)) X DIS("""_M_""") I $T" D SD
 I $D(DIAR) S DIAR(DIARF,DQ)="X DIS("""_M_"A"")"
 S DQ=M,DIS(DQ)="F E=0:0 X DIS("""_DQ_"A"") X:D"_D_"'>0 ""IF "_(DN=3)_""" Q:"_$E("'",DN>1)_"$T  S D"_D_"=$O("_DC_Z_",D"_D_")) Q:D"_D_"'>0"
 S DQ=DQ_"A",DQ(DL)=DQ I DU'[C S DIS(DQ)="I $S($D(^(D"_D_",0)):^(0),1:"""")"_DV G MAKE
 S O=+$P(^(0),U,2),DK(DL)=O,Z=Z_",D"_D_C
N S DU=$P(DU,C,2,99) G LEV
 ;
M I $D(^(2)),$P(^(0),U,2)'["D" S M=0,Y="S Y="_Y_" "_^(2)_" I Y" G E
 I $D(DIS(U,S)) S Y="S Y="_Y_" I $S(Y="""":"""",$D(DIS(U,"_S_",Y)):DIS(U,"_S_",Y),1:"""")" G E
 S M=Y,Y="I "_Y
E S Y=Y_DV D SD G MAKE
 ;
SD I $D(R(DQ)),R(DQ)>1 S Y="K D "_Y_" S:$T D=1"
 I '$D(DIS(DQ)) S DIS(DQ)=Y Q
 I $S($D(DL(DQ)):$L(DL(DQ))*8,1:0)+$L(DIS(DQ))+$L(Y)>180 F %Y=1:1 S %=DQ_"@"_%Y I '$D(DIS(%)) S DIS(%)=Y,Y="X DIS("""_%_""") I $T" Q
 S DIS(DQ)=DIS(DQ)_" "_Y Q
 ;
X S D=DY(-DU),O=+D,DC=U_$P(D,U,2) F %=66:1 S M=DQ_$C(%) Q:'$D(DIS(M))
 I $P(D,U,3) S M=DQ_U_$P(D,U,3),Y="S DIXX="""_M_""" "_$P("X ""I 0"" ^I 1 ",U,DN=3+1)_$P(D,U,4,99)_" I $T",R(M)=DN
 E  S Y=$P(D,U,4,99)_" S D0=D(0) X DIS("""_M_""") S D0=I(0,0) I $T"
 D SD S DQ=M,DI(DL)=DC,DK(DL)=+D,DQ(DL)=DQ,D=0,Z="D0," G N

DIS2
DIS2 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;9/20/94  15:11
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DISV G G:'DUZ
0 D  K DIRUT,DIROUT I $D(DTOUT)!($D(DUOUT)) G Q
 . N DIS,DIS0,DA,DC,DE,DJ,DL D S3^DIBT1 Q
 I X="" G G:'$D(DIAR)
 I Y<0 G Q:X=U,0
 I $D(DIARU),DIARU-Y=0 W $C(7),!,"Archivers must not store results in the default template" G 0
 S (DIARI,DISV)=+Y,A=$D(^DIBT(DISV,"DL")) S:$D(DIS0)#2 ^("DL")=DIS0 S:$D(DA)#2 ^("DA")=DA S:$D(DJ)#2 ^("DJ")=DJ
 I $D(DIAR),'$D(DIARU) S $P(^DIAR(1.11,DIARC,0),U,3)=DISV
 S Z=-1,DIS0="^DIBT(+Y," F P="DIS","DA","DC","DE","DJ","DL" S %Y=DIS0_""""_P_""",",%X=P_"(" D %XY^%RCR
 S %X="^UTILITY($J,",%Y="^DIBT(DISV,""O"",",@(%X_"0)=U") D %XY^%RCR
G N DISTXT S %X="^UTILITY($J,",%Y="DISTXT(" D %XY^%RCR
 W ! S Y=DI D Q S DIC=Y G EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP
 ;
TEM ;
 K DIC S X=$P($E(X,2,99),"]",1),DIC="^DIBT(",DIC(0)="EQ",DIC("S")="I "_$S($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
 S DIC("W")="X ""F %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0))  W !?9 S I=^(0) W:$L(I)+$X>79 !?9 W I"""
 D ^DIC K DIC G F^DIS:Y<0
 S P="DIS",Z=-1,%X="^DIBT(+Y,P,",%Y="DIS(" D %XY^%RCR
 S %Y="^UTILITY($J,",P="O" D %XY^%RCR
 G DIS2
 ;
COMP ;
 S E=X,DICMX="X DIS(DIXX)",DICOMP=N,DQI="Y(",DA="DIS("""_$C(DC+64)_DL_"""," I '$D(O(DC))#2 S O(DC)=X
 G COLON:X?.E1":"
 I X?.E1":.01",'$D(O(DC))#2 S O(DC)=$E(X,1,$L(X)-4)
 D EN^DICOMP,XA G X^DIS:'$D(X),X^DIS:Y["m" ;I Y["m" S X=E_":" G COMP
 S DA(DC)=X,DU=-DC,E=$E("B",Y["B")_$E("D",Y["D")
 G G^DIS
XA S %=0 F  S %=$O(X(%)) Q:%=""  S @(DA_%_")")=X(%)
 S %=-1 Q
COLON D ^DICOMPW G X^DIS:'$D(X) D XA
 S R(DL)=R,N(DL)=N,N=+Y,DY=DY+1,DV(DL)=DV,DL(DL)=DK,DL=DL+1,DV=DV_-DY_C,DY(DY)=DP_U_$S(Y["m":DC_"."_DL,1:"")_U_X,R=U_$P(DP,U,2)
 K X G R^DIS
 ;
Q ;
 K DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE,DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT,^UTILITY($J)
 Q
DIS ;PUT SET LOGIC INTO DIS FOR SUBFILE
 S %X="" F %Y=1:1 S %X=$O(DIS(%X)) Q:'%X  S %=$S($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) S:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) S ^DIAR(1.11,DIARC,"S",%Y,0)=%X,^(1)=%
 S:%Y>1 %Y=%Y-1,^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y G ^DIS2

DIS3
DIS3 ;SFISC/SEARCH - PROGRAMMER ENTRY POINT ;12/16/93  13:16
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
 N DIQUIET,DIFM S L=$G(L),DIFM=+L D CLEAN^DIEFU,INIT^DIP
 S:$G(DIC) DIC=$G(^DIC(DIC,0,"GL")) G QER1:$G(DIC)="" N DK S DK=+$P($G(@(DIC_"0)")),U,2) G QER1:'DK
 N DISV,Y D  S DISV=+Y I Y<0 S DIC="DISTEMP" G QER
 .N DIC,X,DIS S Y=-1,DIS=$G(DISTEMP) Q:DIS=""
 .S X=$S($E(DIS)="[":$P($E(DIS,2,99),"]"),1:DIS),DIC="^DIBT(",DIC(0)="Q",DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
 .D ^DIC Q
 N DISTXT S %X="^DIBT(DISV,""DIS"",",%Y="DIS(" D %XY^%RCR
 S %X="^DIBT(DISV,""O"",",%Y="DISTXT(" D %XY^%RCR
 K ^DIBT(DISV,1)
 D EN1^DIP G EXIT
 ;
QER1 S DIC="DIC"
QER D BLD^DIALOG(201,DIC) D:'$G(DIQUIET) MSG^DIALOG()
 D Q^DIP
EXIT K DIC,DISTEMP Q
 ;DIALOG #201  'The input variable...is missing or invalid.'

DIT
DIT ;SFISC/GFT-GET XFR ANSWERS ;4/6/94  13:03
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DIT""," G OPT:$D(^DOPT("DIT",2)) S ^(0)="TRANSFER OPTION^1.01" K ^("B")
 F X=1,2 S ^DOPT("DIT",X,0)=$P("TRANSFER^COMPARE/MERGE",U,X)_" FILE ENTRIES"
 S DIK=DIC D IXALL^DIK
OPT W !! S DIC(0)="AEQZI" D ^DIC G Q:Y<0 I +Y=2 D ^DITM K DIC G 0
 D Q S DLAYGO=1 D W^DICRW G Q:$D(DTOUT) Q:Y<0  S DFL=$P(Y,U,2)_": " I '$D(DIC) D DIE^DIB Q:'$D(DG)  S L=DG,Y=DLAYGO K DG,DIE,DQ G FROM
 S DIC("B")=+Y,L=DIC
FROM S DMRG=1,DKP=1,(DDF(1),DDT(0))=+Y,DIC=1,DIC(0)="EQAZ",DIC("A")="TRANSFER FROM FILE: "
 S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
 D ^DIC K DIC G Q:Y<0,Q:'$D(^(0,"GL")) S DTO=^("GL") I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",+Y,0)):1,1:$D(^DIC(3,DUZ,"FOF",+Y,0))) G DTR:+$P(^(0),U,3),Q
 I DUZ(0)'="@",$D(^DIC(+Y,0,"DEL")) F X=1:1 G Q:X>$L(^("DEL")) Q:DUZ(0)[$E(^("DEL"),X)
DTR D PTS I +Y=DDF(1) G ^DIT0
TWO S (DTO(0),F)=L,L(+Y)=DDT(0),L=0,DDF(1)=+Y,DFR(1)=DTO_"D0,",DHIT=DLAYGO-(Y#1),%=0
 W !! K ^UTILITY("DITR",$J),A I DLAYGO-1 W "DO YOU WANT TO TRANSFER THE '",$P(Y,U,2),"'",!,"DATA DICTIONARY INTO YOUR NEW FILE" D YN^DICN G Q:%<1 D ^DIT1:%=1
 K DITF,Y,B W ! G Q:'$D(L)
 D MAP I '$D(DITF) W $C(7),"FILES DON'T MATCH!" G Q
 W:$X>40 ! W:'$D(A) "  WILL BE TRANSFERRED",!!
 S %=2,DMRG=0 I @("$O("_DTO(0)_"0))>0") W !,"WANT TO MERGE TRANSFERRED ENTRIES WITH ONES ALREADY THERE" D YN^DICN G Q:%<1 I %=1 S DMRG=1
 S (DIK,DIC)=DTO,DTO=1,L="TRANSFER ENTRIES",FLDS="",DHD="@",%ZIS="F"
D S %=0 W !,"WANT EACH ENTRY TO BE DELETED AS IT'S TRANSFERRED" D YN^DICN S DHIT="S DI=99 D F^DITR"_$P(",^DIK",%,%=1) G Q:%<0 I '% D F G D
 S DISTOP=0,DIOEND="S DIK=DTO(0),DIK(0)=""B"" D KL^DIT,IXALL^DIK,Q^DIT" D EN1^DIP
Q ;
 K ^UTILITY("DITR",$J),^UTILITY("DIT",$J),DIT,DIC,DA,DB1,DFR,DIK,L,FLDS,DHIT,DISTOP,DIOEND,%ZIS
KL K DIU,DIV,DIG,DIH,DLAYGO,DITF,DFN,DMRG,DTO,DTN,DDF,DTL,DFL,DDT,A,B,DKP,W,X,FLDS,Y,Z Q
 ;
MAP ;BUILD MAP OF FIELDS FROM 'FROM' TO 'TO' FILE
 N DFL S DFL=1
MAP2 ;ENTRY POINT FROM ^DIT3
 K:L]"" L(L) S L=$O(L(0)) Q:L']""
 F Y=0:0 S Y=$O(^DD(L,Y)) G MAP2:Y="",MAP2:'$D(^(Y,0)) S %=^(0) I $P(%,U,2)'["C" S DIC=$P(%,U,1),X=$O(^DD(L(L),"B",DIC,0)) I X>0,'^(X),$P(^DD(L(L),X,0),U,2)'["C" D T
 Q
T S Z=$P(^(0),U,4),V=$P($P(^(0),U,2),U,Z[";0"),^UTILITY("DITR",$J,L,Y)=$P(Z,";",2)_U_$P(Z,";",1) S:V ^(Y)=^(Y)_U_V,L(+$P(%,U,2))=+V I Z="0;1",DDF(DFL)=L S DITF=$P(%,U,4)
 Q:$D(A)  W:$X ", " W:$L(DIC)+$X>66 ! W "'"_DIC_"' FIELDS" Q
 ;
PTS ;
 S DL=0 F X=0:0 S X=$O(^DD(+Y,0,"PT",X)) Q:X'>0  F Z=.001:0 S Z=$O(^DD(+Y,0,"PT",X,Z)) Q:Z'>0  I $D(^DD(X,Z,0))#2 S %=^(0) I (U_$P(%,U,3)=DTO!($D(^DD(X,Z,"V","B",+Y)))),$P(%,U,2)'["I" S DL=DL+1,^UTILITY("DIT",$J,0,DL)=X_U_Z_U_$P(%,U,2)
 Q
 ;
F W !?7,"(TYPE '^' TO FORGET THE WHOLE THING!)",!
 Q
 ;
TRNMRG(DIFLG,DIFFNO,DITFNO,DIFIEN,DITIEN) ; SILENT TRANSFER/MERGE OF SINGLE RECORDS IN FILE OR SUBFILE
 ;DIFLG  = FLAGS
 ;DIFFNO = TRANSFER 'FROM' FILE/SUBFILE NO. OR ROOT
 ;DITFNO = TRANSFER 'TO' FILE/SUBFILE NO.
 ;DIFIEN = TRANSFER 'FROM' IEN STRING
 ;DITIEN = TRANSFER 'TO' IEN STRING (PASS BY REFERENCE)
 G TRNMRG^DIT3

DIT0
DIT0 ;SFISC/XAK-PREPARE TO XFR ;09:21 AM  Jul 19, 1988;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K Y,DIC S DIT=DDF(1),DIC=L,DIC(0)="EQLAM",X="DATA INTO WHICH " D LK
 G Q:Y<0 S DFR=+Y,DTO(1)=DIC_+Y_",",DIC(0)="EQAM",X="FROM ",DIC("S")="I Y-"_+Y D LK G Q:Y<0
S S %=2 W !,"   WANT TO DELETE THIS ENTRY AFTER IT'S TRANSFERRED" D YN^DICN G Q:%<0 S DH=2-% I '% D F^DIT G S
 S ^UTILITY("DIT",$J,+Y)=DFR_";"_$E(DIC,2,999)
 S DTO=0,(D0,DA)=+Y,DIK=DIC,DFR(1)=DIC_DA_"," K DIC D WAIT^DICD
GO D GO^DITR
 S DIT=DH D KL^DIT,^DIK:DH S DA=DFR K DFR D IX1^DIK
 S DH=DIT D ASK^DITP,PTS^DITP:%=1
Q G Q^DIT
 ;
LK S DIC("A")="TRANSFER "_X_DFL G ^DIC
 ;
EN ; PROGRAMMER CALL
 ; DIT("F") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER FROM
 ; DIT("T") = GLOBAL ROOT OR FILE # OF FILE TO TRANSFER TO
 ; DA("F")  = ENTRY # IN FILE TO TRANSFER FROM
 ; DA("T")  = ENTRY # IN FILE TO TRANSFER TO
 ;
 I '$D(DIT("F"))!'$D(DIT("T"))!'$D(DA("F"))!'$D(DA("T")) G FIN
 S DDF(1)=DIT("F"),DDT(0)=DIT("T")
 I 'DDF(1) S DDF(1)=$S($D(@(DDF(1)_"0)"))#2:+$P(^(0),U,2),1:0) G FIN:'DDF(1) S DFR(1)=DIT("F")
 I 'DDT(0) S DDT(0)=$S($D(@(DDT(0)_"0)"))#2:+$P(^(0),U,2),1:0) G FIN:'DDT(0) S DTO(1)=DIT("T") G C
 G FIN:'$D(^DIC(+DDF(1),0,"GL")) S DFR(1)=^("GL")
 G FIN:'$D(^DIC(+DDT(0),0,"GL")) S DTO(1)=^("GL")
C S DB=DA("F"),(DB1,DFR)=DA("T"),DIK=DTO(1)
 I $D(DA(1)) F I=1:1 G:'$D(DA(I)) SET S DRF(I)=$P(DA(I),",",1)_",1,",DOT(I)=$P(DA(I),",",2)_",1,"
DON K DRF,DOT S DFR(1)=DFR(1)_DB_",",DTO(1)=DTO(1)_DB1_",",DKP=1,DMRG=1,DTO=0,DH=0 G GO
SET F I=I-1:-1 G:I'>0 DON S DFR(1)=DFR(1)_DRF(I),DTO(1)=DTO(1)_DOT(I)
FIN ;
 K DDF,DFR,DDT,DTO
 Q

DIT1
DIT1 ;SFISC/GFT,TKW-TRANSFER DD'S ;10/9/90  11:59 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K A W !! S A=+Y,E=A
CHK F V=0:0 S V=$O(^DD(A,"SB",V)) Q:'V  S A(V)=0,L(V)=DLAYGO_$P(V,E,2,9)
 S A=$O(A(0)),B=A#1+DHIT I A'="" K A(A) G P:$P(DHIT,".",1)+1'>B,CHK:'$D(^DD(B)),P:DHIT["." S X=$P(^(B,0),U,1) S:$D(^DIC(B,0)) X=$P(^(0),U,1)_" FILE" W $P(^DD(A,0),U,1)_" WOULD COLLIDE WITH "_X,$C(7),! K L,A Q
 S A=$O(L(0)) I A S %X="^DIC("_A_",""%D"",",%Y="^DIC("_L(A)_",""%D""," D %XY^%RCR
 D WAIT^DICD F A="^DIE(","^DIPT(","^DIBT(" F V=0:0 S V=$O(@(A_"V)")) Q:'V  I $D(^(V,0)),$P(^(0),U,4)-Y=0 S ^UTILITY("DITR",$J,A,V)=$P(^(0),U,1)
 S A="F B=0:0 Q:F=DTO!'$F(W,DTO)  S W=$P(W,DTO)_F_$P(W,DTO,2,9)"
 G GO:$O(^UTILITY("DITR",$J,-1))="" W !,"DO YOU WANT TO COPY '",$P(Y,U,2),"'S TEMPLATES INTO YOUR NEW FILE" D YN^DICN W !
 I %=1 S E="I DIK=""^DIBT("",%Z=1,$D(L(+W)) S $P(W,U,1)=L(+W)" F DIK="^DIE(","^DIPT(","^DIBT(" S V=$P(@(DIK_"0)"),U,3),%X=DIK_"Z,",%Y=DIK_"V," D ^DIT2,IXALL^DIK
GO S Y=DLAYGO K ^UTILITY("DITR",$J),^DD(Y,"B"),^(.01),^("IX"),^("RQ"),^(0,"IX"),E
 S @("V=$P("_DTO_"0),U,2)"),@("^(0)=$P("_DTO(0)_"0),U,1,2)_$P(V,DDF(1),2)_U_U")
DD W ! S L=$O(L(L)),Y=L#1+DHIT Q:L=""  S B=0,V=$O(^DD(L,0,"NM",0)),^DD(Y,0)=^DD(L,0) I V]"",$O(^(0,"NM",0))="" S ^(V)=""
 S V=-1 I $D(^DD(L,0,"UP")) S ^DD(Y,0,"UP")=^("UP")#1+DHIT
ID S V=$O(^DD(L,0,"ID",V)) I V]"",$D(^(V))#2 S W=^(V) X A S ^DD(Y,0,"ID",V)=W G ID
 F V=0:0 S V=$O(^DD(L,V)) Q:'V  I $D(^(V,0)) W "." S W=^(0),D=$P(W,U,2),%Z=0,%A="" S:D L(+D)=D#1+DHIT,W=$P(W,U,1)_U_L(+D)_$P(D,+D,2,9)_U_$P(W,U,3,99) X A D Y S ^DD(Y,V,0)=W,%B=0 D N
 S DA(1)=Y,DIK="^DD("_Y_"," D IXALL^DIK K %A,%B,%C,%Z G DD
 ;
P W $C(7),"FILE #"_+Y_" SHOULD ONLY BE TRANSFERRED TO A FILE WHOSE NUMBER",!?8,"ALSO "_$S(Y#1:"ENDS WITH '"_(Y#1)_"'",1:"IS INTEGER") K L,A Q
 ;
N S %B=$O(@("^DD(L,V,"_%A_"%B)")) G:%B=5 N I %B="" Q:'%Z  S @("%B="_$P(%A,",",%Z)),%Z=%Z-1,%A=$P(%A,",",1,%Z)_$E(",",%Z>0) G N
 I @("$D(^DD(L,V,"_%A_"%B))#2") S W=^(%B) D D S @("^DD(Y,V,"_%A_"%B)=W")
 I @("$D(^DD(L,V,"_%A_"%B))<9") G N
 S:+%B'=%B %B=""""_%B_"""" S %A=%A_%B_",",%Z=%Z+1,%B=-1 G N
 ;
D X A
Y F DTL=0:0 S DTL=$O(L(DTL)) Q:'DTL  F %=2:1 S B=$P(W,DTL,%,999) Q:B=""  S:'B W=$P(W,DTL,1,%-1)_(DTL#1+DHIT)_B,%=%-1

DIT2
DIT2 ;SFISC/GFT-TRANSFER TEMPLATES ;10/16/90  9:37 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
TEM F Z=0:0 W "." S Z=$O(^UTILITY("DITR",$J,DIK,Z)) Q:Z=""  F V=V:1 I $O(@(%Y_"0)"))="" D %XY S ^(0)=$P(@(%Y_"0)"),U,1,3)_U_DDT(0)_U_$P(^(0),U,5,99) K ^("ROU"),^("ROUOLD") K:DIK="^DIBT(" ^DIBT(V,1) Q
 Q
%XY ;
 S %Z=0,%A="",%C(-1)=0,%E=""
S S %B=-1
N S @("%B=$O("_%X_%A_"%B))") S:%B="" %B=-1 S %C(%Z)=%C(%Z-1),%D=$S($D(L(%B)):L(%B),1:%B)
 I %B=-1 Q:'%Z  S @("%B="_$P(%A,",",%Z+%C(%Z-2),%Z+%C(%Z-1))),%Z=%Z-1,%A=$P(%A,",",1,%Z+%C(%Z-1))_$E(",",%Z>0),%E=$P(%E,",",1,%Z+%C(%Z-1))_$E(",",%Z>0) G N
 I $D(@(%X_%A_"%B)"))#2 S W=^(%B) X A D Y^DIT1 X E S @(%Y_%E_"%D)=W") I %A="""DCL""," S ^(%B#1+DHIT_U_$P(%B,U,2))=^(%B) K ^(%B) G N
 I @("$D("_%X_%A_"%B))<9") G N
 S:+%B'=%B %B=""""_%B_"""" S:+%D'=%D %D=""""_%D_""""
 S %A=%A_%B_",",%Z=%Z+1,%E=%E_%D_"," G S
 ;
DCL ;S ^(%B#1+DHIT_U_$P(%B,U,2))=^(%B) K ^(%B) G N
 ;

DIT3
DIT3 ;SFISC/TKW - SILENT TRANSFER/MERGE ROUTINE ;10/14/94  13:50
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
TRNMRG ; TRANSFER OR MERGE RECORDS SILENTLY (CALLED FROM TRNMRG^DIT)
 N I,J,Z,DITYPM,DDF,DDT,DFR,DMRG,DKP,DTO,DFL,DTL,DA,DIZZ,DIERRMSG,DIK,DITF D CLEAN^DIEFU
 F I=1:1 S DITYPM=$E(DIFLG,I) Q:DITYPM=""  Q:"MOAR"[DITYPM
 I DITYPM="" G ERR0
 I '$G(DIFFNO),$G(DITFNO) S DFR=DIFFNO,DIFFNO=+DITFNO I $E(DFR,$L(DFR))=")" S DFR=$$OREF^DIQGU(DFR)
 I '$G(DIFFNO)!('$D(^DD(+$G(DIFFNO),.01,0))) S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8084) G ERR3
 S DITFNO=+$G(DITFNO) S:'DITFNO DITFNO=DIFFNO I DITFNO'=DIFFNO,'$D(^DD(DITFNO,.01,0)) S DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8084) G ERR3
 I '$G(DIFIEN) S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8085) G ERR3
 F I=0:1 S J=$P(DIFIEN,",",I+1) Q:'J  S DA(I)=J,DFL=I*2+1
 S (I,J)=I-1 D  G:I'=J ERR5
 . I I=0,$D(^DD(DIFFNO,0,"UP")) S J=-1 Q
 . N Z S Z=DIFFNO,J=0 F  Q:'$D(^DD(Z,0,"UP"))  S J=J+1,Z=^("UP")
 . Q
 S J=0
SD0 N @("D"_J) S @("D"_J)=DA(I),I=I-1,J=J+1 I I>-1 G SD0
 S DA=DA(0) K DA(0)
 S DDF(DFL)=DIFFNO,DDT(DFL-1)=DITFNO S:DIFFNO=DITFNO DDT(DFL)=DITFNO
 S DFR(DFL)=$S($G(DFR)]"":DFR,1:$$ROOT^DIQGU(DIFFNO,DIFIEN,"",1))_+DIFIEN_"," Q:$D(DIERR)  G:'$D(@(DFR(DFL)_"0)")) ERR1 S DIZZ=^(0)
 S:$G(DITIEN)="" DITIEN="+?1,"_$P(DIFIEN,",",2,99)
 Q:'$$IENCHK(DITFNO,DITIEN)
 S (DTO(DFL-1),DIK)=$$ROOT^DIQGU(DITFNO,DITIEN,"",1) Q:$D(DIERR)
 I DITIEN S DTO(DFL)=DTO(DFL-1)_+DITIEN_"," I '$D(@(DTO(DFL)_"0)")) G ERR2
 I 'DITIEN,$D(^DD(DITFNO,0,"UP")) D  I '$D(DITIEN) G ERR2
 . N X,Y,Z S X=^DD(DITFNO,0,"UP"),Y=$P(DITIEN,",",2,99),Z=$$ROOT^DIQGU(X,Y) I $D(DIERR) K DITIEN Q
 . I '$D(@(Z_$P(Y,",")_",0)")) K DITIEN Q
 . I $P($G(^DD(DITFNO,.01,0)),U,2)["W" K DITIEN Q
 . I '$D(@(DTO(DFL-1)_"0)")) S Z=$O(^DD(X,"SB",DITFNO,0)) I Z S Z=$P($G(^DD(X,Z,0)),U,2) I Z S @(DTO(DFL-1)_"0)")="^"_Z_"^^"
 . Q
 I DIFFNO'=DITFNO D  I '$D(DITF) G ERR4
 . N %,A,L,V,X,Y,Z,DIC K ^UTILITY("DITR",$J)
 . S A=1,L=0,L(DDF(DFL))=DDT(DFL-1)
 . D MAP2^DIT Q
 S DMRG=$S(DIFLG["A":0,1:1),DKP=$S(DIFLG["M":1,1:0),DTO=$S(DIFFNO=DITFNO:0,1:1)
 N %,A,B,V,W,X,Y,DFN,DTN,DINUM,DIC,DIIX
 I 'DITIEN D  Q:A
 . S (DFL,DTL)=DFL-1,Z=DIZZ D ^DITR1 Q:A
 . S DFL=DFL+1,DITIEN=+Y_","_$P(DITIEN,",",2,99)
 . Q
 S DTL=DFL,DFN(DFL)=-1 D N^DITR
 I DIFLG'["X" Q
 K DA F I=1:1 S J=$P(DITIEN,",",I) Q:'J  S:I=1 DA=J I I>1 S DA(I-1)=J
 D IXALL^DIK
 Q
 ;
IENCHK(DIFILE,DIIEN) ;EXTRINSIC FUNCTIO TO CHECK THAT IEN STRING AND FILE/SUBFILE NO. ARE IN SYNC
 ;DIFILE=file/subfile#, DIIEN=IEN string
 N I,J
 S I=$L($G(DIIEN),",") I I=1 G ERX
 S I=I-1,J=0 D  I I'=J G ERX
 . I I=1,$D(^DD(DIFILE,0,"UP")) Q
 . S J=1 F  Q:'$D(^DD(DIFILE,0,"UP"))  S J=J+1,DIFILE=^("UP")
 . Q
 Q 1
ERX K I S I(1)=DIFILE,I("IENS")=DIIEN D BLD^DIALOG(205,.I) Q 0
 ;
ERR0 D BLD^DIALOG(301,DIFLG) Q
ERR1 S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8078) G ERR3
ERR2 S DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8078)
ERR3 D BLD^DIALOG(202,DIERRMSG) Q
ERR4 D BLD^DIALOG(1504) Q
ERR5 K I S I(1)=DIFFNO,I("IENS")=DIFIEN D BLD^DIALOG(205,.I) Q
 ;202  The input param...that identifies...|1| is missing or invalid.
 ;205  File...number and IEN string represent different...levels.       
 ;301  The passed flag(s) '|1|' are unknown or inconsistent.
 ;1504  No matching .01 field names...Transfer/Merge cannot be done
 ;8082  Transfer FROM
 ;8083  Transfer TO
 ;8084  file number
 ;8085  IEN string
 ;

DITC
DITC ;SFISC/XAK-MERGE OR COMPARE ENTRIES ;9/17/91  10:36 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
START ;
 K DFF,DIT,DIMERGE,DDSP,DDIF,DDEF,DITC,DMSG
 D K2,K1,T^DICRW G:Y<0 END S (DSUB,DIT,L)=0,DSUB(L)=DIC,DITC=1
SUB S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA
ENTR G:X["^"!($D(DTOUT)) END K DIC S DIC(0)="AEQMZ",DIC=DSUB(0),DFL=1,DIT=DIT+1,DIT(DIT)="" W:DIT=1 !
E1 S DIC("A")=$E("        ",1,DFL-1*3)_$S(DIT=2:" WITH ",1:"COMPARE ")_DFL(DFL)_": " I (DIT=2),(DFL=L),($P(DIT(1),",",1,L-1)=$P(DIT(2),",",1,L-1)) S DIC("S")="I Y-"_$P(DIT(1),",",L)
 D ^DIC K DIC("S"),DIC("A") I Y>0,$D(DSUB(DFL)),$D(DFL(DFL+1)) S DIC=DIC_+Y_","_DSUB(DFL),DIT(DIT)=DIT(DIT)_+Y_",",DFL=DFL+1 S %=$O(@(DIC_"-1)")) G:'% E1 S:%>0 ^(0)=U_DFF_U I %<0 W !,"NO "_DFL(DFL) S Y=-1
 G:X=U END G:Y=-1 START S DTO(DIT)=DIC_+Y_",",DTO(DIT,"X")=Y(0,0),DIT(DIT)=DIT(DIT)_+Y G:DIT=1 ENTR S DDSP=1
Q1 S %=2 W !!,"WILL YOU WANT TO MERGE THESE ENTRIES AFTER COMPARING THEM" D YN^DICN I '% W ! S DMSG=1 D HELP^DITC0 G Q1
 S:%=1 DIMERGE=1 G:%<0 END G:'$D(DIMERGE) Q2 W ! F I=1,2 W !?5,I,?10,DTO(I,"X")
Q15 R !!,"WHICH ENTRY SHOULD BE USED FOR DEFAULT VALUES (1 OR 2)? ",X:DTIME S:X[U DUOUT=1 S:'$T X=U,DTOUT=1 G:X["^" END I X="?" S DMSG=3 D HELP^DITC0 G Q15
 I X'=1,X'=2 W $C(7),!,"Enter '1' or '2'" G Q15
 S DDEF=X
Q2 S %=2 W !!,"DO YOU WANT TO DISPLAY ONLY THE DISCREPANT FIELDS" D YN^DICN I '% S DMSG=2 D HELP^DITC0 G Q2
 S:%=1 DDIF=1 G:%<0 END G PRNT^DITC1
EN ;
 D K2
EN2 ;
 D K1 S DMSG=0 F I="DFF","DIT(1)","DIT(2)" Q:DMSG  I '$D(@I) S DMSG=1,DMSG(1)=I
 G:DMSG ERREND^DITC0 F I="DFF","DIT(1)","DIT(2)" Q:DMSG  I '$L(@I) S DMSG=2,DMSG(1)=I
 G:DMSG ERREND^DITC0 I '$D(^DD(DFF)) S DMSG=3,DMSG(1)=DFF G ERREND^DITC0
 S:'$D(DFL) N=$O(^DD(DFF,0,"NM",-1))_U,X1=1,M=DFF_U
 S DITC=1,K=DFF,DSUB=0
 F I=0:0 Q:'$D(^DD(K,0,"UP"))  S J=^("UP"),I=$O(^DD(J,"SB",K,-1)),DSUB=DSUB+1,DSUB(DSUB)=""""_$P($P(^DD(J,I,0),U,4),";",1)_""",",K=J S:'$D(DFL) N=N_$O(^DD(K,0,"NM",-1))_U,M=M_K_U,X1=X1+1
 S DSUB=DSUB+1,DSUB(DSUB)=^DIC(K,0,"GL") I '$D(DFL) F DFL=1:1:X1 S DFL(DFL)=$P(N,U,X1-DFL+1),DFF(DFL)=$P(M,U,X1-DFL+1)
 S DMSG="" F I=1:1:2 S DTO(I)="" I DIT(I)'=0 F K=DSUB:-1:1 S DTO(I)=DTO(I)_DSUB(K)_$P(DIT(I),",",DSUB-K+1)_"," I '$L($P(DIT(I),",",DSUB-K+1)) S DMSG=4,DMSG(1)="DIT("_I_")"
 F I=1,2 I $L($P(DIT(I),",",DSUB+1,99)) S DMSG=4,DMSG(1)="DIT("_I_")"
 G:$L(DMSG) ERREND^DITC0 K DMSG G PRNT^DITC1
K1 ;
 K %H,DSUB,DTO,DFL,DNUM
 Q
K2 ;
 K D001,DHD,DUOUT,DTOUT,DIRUT,^UTILITY($J,"DIT"),^("DITI"),^("DITDINUM")
 Q
END ;
 I $D(DTOUT)!($D(DUOUT)) S DIRUT=1
 D K1 K DIMERGE,DDSP,DDIF,DDEF,DIT,DFF,DDSH,DDSPC,DEQ,DIACT,X,X2,POP,DHD,D,Y,X1,^UTILITY($J,"DIT"),^("DITI"),^("DITDINUM")
 K DITC
 Q

DITC0
DITC0 ;SFISC/XAK-COMPARE FILE ENTRIES ;12/3/90  12:38
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; Mandatory INPUT VARIABLES using entry point EN:
 ; DFF ...... File or subfile number
 ; DIT(1) ... Internal number of first entry
 ; DIT(2) ... Internal number of second entry
 ;
 ; Optional INPUT VARIABLES using entry point EN:
 ; DIMERGE ..... If defined, allows for merge; if not, does compare only
 ; DDSP ..... If defined, writes 'wait messages and dots' to the screen
 ; DDIF ..... If undefined displays all fields
 ; DDIF=1: displays discrepant only
 ; DDIF=2: displays discrepant and missing as well
 ; DDEF ..... Entry # (1 or 2) from which to take default values.
ERREND ;
 S DMSG=$P($T(ERRTXT+DMSG),";; ",2)_": "_DMSG(1) W !,DMSG
 G END^DITC
 Q
ERRTXT ;;
 ;; Undefined INPUT VARIABLE
 ;; Null INPUT VARIABLE
 ;; Nonexistent FILE
 ;; Incorrect INPUT VARIABLE specification
HELP ;;
 W ! F I=1:1 S J=$P($T(@("HTXT"_DMSG)+I),";; ",2) Q:'$L(J)  W !,J
 Q
HTXT1 ;;
 ;; Enter a 'N' if you wish only to compare and display the two
 ;; entries.  Enter a 'Y' if you wish to choose valid fields from each
 ;; entry and eventually do a merge into record selected for default.
HTXT2 ;;
 ;; Enter a 'N' if you wish to display all of the fields in each entry.
 ;; Enter a 'Y' if you wish to display only those fields which differ.
HTXT3 ;;
 ;; On merging, the default field value can be taken from entry #1 or #2.
 ;; You will later have the opportunity to modify this default selection
 ;; on a field by field basis.  Please note that the two records will
 ;; always be merged into the record selected as the default selection.
HTXT4 ;;
 ;; When the two entries are compared, all top level fields are displayed
 ;; and a summary for multiple level fields are displayed. If you also wish to
 ;; see a detailed comparison on the multiple level fields, enter 'Y'.
 ;;
 ;;

DITC1
DITC1 ;SFISC/XAK-COMPARE FILE ENTRIES PRINT ;7/1/93  4:31 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
PRNT S %ZIS("B")="",%ZIS=$S($D(DIMERGE):"M",1:"QM") D ^%ZIS G:POP END^DITC I $D(IO("Q")) G QUE
COMP W:$D(DDSP) !,"COMPARING THE TWO ENTRIES" F I=1:1:2 I $L(DTO(I)) S J=-1 F K=0:0 S @("J=$O("_DTO(I)_"J))") Q:J=""  W:$D(DDSP) "." D EACH
 D DISP
 Q
EACH ;
 I @("$D("_DTO(I)_"J))'<10") D MUL Q
 S X=^(J) F N=1:1 D:$L($P(X,U,N)) SETU Q:'$L($P(X,U,N,999))
 Q
SETU ;
 I '$D(^UTILITY($J,"DIT",J,N,0)) S @("Y=$O(^DD("_DFF_",""GL"",J,"_N_",-1))") Q:Y=""  S %=^DD(DFF,Y,0),^UTILITY($J,"DIT",J,N,0)=Y_U_$P(%,U,1)_U I Y=.01,$P(%,U,5,999)["DINUM" S ^UTILITY($J,"DITDINUM",J,N,0)=""
 S O=+^UTILITY($J,"DIT",J,N,0) S:$P(^DD(DFF,O,0),U,2)["O" ^UTILITY($J,"DITI",J,N,I)=$P(X,U,N)
 S C=^DD(DFF,O,0),O=$P(C,U,1),C=$P(C,U,2),D0=DIT(I),Y=$P(X,U,N) D Y^DIQ S ^UTILITY($J,"DIT",J,N,I)=Y
 Q
MUL ;
 I '$D(^UTILITY($J,"DIT",U,J,0)) S @("Y=$O(^DD("_DFF_",""GL"",J,0,-1))") Q:Y=""  S ^UTILITY($J,"DIT",U,J,0)=Y_U_$P(^DD(DFF,Y,0),U,1)_U
 S N=0 F L=0:1 S @("N=$O("_DTO(I)_"J,N))") Q:'N
 S $P(^UTILITY($J,"DIT",U,J,0),U,I+3)=L
 Q
DISP ;
 U IO
 I $D(DIMERGE) S J=-1 F  S J=$O(^UTILITY($J,"DIT",J)) Q:U[J  S N=-1 F  S N=$O(^UTILITY($J,"DIT",J,N)) Q:N=""  D D11^DITC2
 S DC=0,DDSH="",$P(DDSH,"-",IOM-1)="-",$P(DDSPC," ",30)=" ",DV=(IOM-1)\3
 S DHD(0)="COMPARISON OF "_DFL(1)_" FILE ENTRIES"
 S R=$S(DSUB(DSUB)[",":1,1:0),%H=$H D YX^%DTC S DHD(9)=$P(Y,":",1,2)
 F I=1:1:2 I $L(DTO(I)) F J=1:2 S K=$P(DTO(I),",",1,J+R) Q:($E(K,$L(K))=",")  D D0
 S DIFF=$S(IOST?1"C".E:1,1:0) D ^DITC2 K DUOUT
 I $D(DTOUT)!('$D(DIMERGE)) G EX
 I IOST'?1"C".E W !!!!,?3,"**** NOW PROCEEDING WITH THE MERGE ****" W @IOF S DIACT="P" D ACT^DITC3 G EX
 I X=U D ASK^DITC3 G EX
 W ! D @($P("ASK",U,'$O(^UTILITY($J,"DIT",U,0)))_"^DITC3")
EX X $G(^%ZIS("C")) G END^DITC
 Q
D0 ;
 I '$D(^DD(DFF(J+1\2),.001,0)) S K=K_",0)" Q:'$D(@K)  S Y=^(0),Y=$P(Y,U,1) Q:'$L(Y)  S C=^DD(DFF(J+1\2),.01,0) G D01
 S Y=$P($P(DTO(I),DIC,2),",",1),C=^DD(DFF(J+1\2),.001,0)
D01 S O=$P(C,U,1),C=$P(C,U,2) D Y^DIQ S $P(DHD(J\2+1),U,I)=Y
 Q
QUE ;
 K Y,K,L,M,N,I,X,X1,C,DDSP,DMSG
 S DJ=0,DHD="COMPARE OF "_DFL(1)_" FILE" D ^DIP4 G END^DITC
 Q
DQ ;
 D NOW^%DTC S DT=X K %,%I G COMP

DITC2
DITC2 ;SFISC/XAK-COMPARE FILE ENTRIES PRINT ;10/15/91  9:01 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S J=-1 D PG1 F K=0:0 S J=$O(^UTILITY($J,"DIT",J)) Q:X=U!(U[J)  S N=-1 F K=0:0 S N=$O(^UTILITY($J,"DIT",J,N)) Q:N=""!(X=U)  D D1 Q:X=U  D:+X(0) D2
 I X'=U D PG Q:X=U  D MUL:$D(^UTILITY($J,"DIT",U))
 Q
D1 ;
 I $Y+6>IOSL,'$D(DREDO) S DIJ=J,DIN=N D PG,PG1:X'=U S J=DIJ,N=DIN K DIJ,DIN
 Q:X=U
D11 F I=0:1:2 S X(I)=$S($D(^UTILITY($J,"DIT",J,N,I)):^(I),1:"") I X(I)["""" D D7
 S DEQ=X(1)=X(2) I $D(DDIF),DEQ I (DDIF=1)!(DDIF=2&$L(X(1))) S X(0)=0 K ^UTILITY($J,"DIT",J,N) Q
 Q:'$D(DIMERGE)  S X1=$P(X(0),U,3) I '$L(X1) S X1=$S(X(1)=X(2):0,'$L(X(DDEF)):'(DDEF-1)+1,1:DDEF),$P(^UTILITY($J,"DIT",J,N,0),U,3)=X1,$P(X(0),U,3)=X1
 Q
D2 ;
 K D S X2=$P(X(0),U,3),X(0)=$P(X(0),U,2)
D20 F I=0:1:2 S X=X(I),X1="" F D=1:1 Q:'$L(X)  D:($L(X)>(DV-6)) D5 S $P(D(D),U,I+1)=$S(I=X2&I:"["_X_"]",1:X) S X=X1,X1=""
D21 F I=1:1 Q:'$D(D(I))  D D3
 Q
D3 ;
 I $D(DREDO),I=1 X:$D(IOXY) IOXY W !,DREDO,".",?4 G D31
 W ! W:(I=1) ! I I=1,$D(DIMERGE) S DNUM=DNUM+1 W DNUM,"." S DNUM(DNUM)=J_U_N_U_$Y
 W:'DEQ&'$D(DIMERGE)&(I=1) "***" W ?4
D31 F X1=1:1:3 I $L($P(D(I),U,X1)) W ?(DV*(X1-1)) W $P(D(I),U,X1)
 I $D(DREDO) W $E(DDSPC,1,3)
 Q
D5 ;
 F K=DV-6:-1:1 Q:$E(X,K)?1P
 I $E(X,K)?1P S X1=$E(X,K+1,999),X=$E(X,1,K) Q
 S X1=$E(X,DV-1,999),X=$E(X,DV-2)
 Q
D7 S X(I)=$P(X(I),"""",1)_"'"_$P(X(I),"""",2,99) I X(I)["""" G D7
 Q
MUL ;
 S DIMUL=1 D PG1 S N=0
 F K=0:0 S N=$O(^UTILITY($J,"DIT",U,N)) Q:N=""!(X=U)  D EMUL
 K DIMUL Q
EMUL ;
 D:$Y+5>IOSL PG
 K D S X2="",J=^UTILITY($J,"DIT",U,N,0),X=$P(J,U,2),X1="",I=0 F D=1:1 Q:'$L(X)  D:($L(X)>(DV-6)) D5 S $P(D(D),U,I+1)=""""_X_"""" S X=X1,X1=""
 S X=J F I=1:1:2 S $P(D(1),U,I+1)=""""_$S('$P(X,U,I+3):"  ---",1:$J($P(X,U,I+3),2)_$S($P(X,U,I+3)>1:" entries",1:" entry"))_""""
 D D21
 Q
PG ;
 I '$D(DIMERGE)!$D(DIMUL) I IOST?1"C".E W $C(7) K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) X=U Q
 W:'$D(IOXY) !! Q:IOST'?1"C".E  I $D(IOXY) S DX=0,DY=IOSL-3 X IOXY W !
 W "Default is enclosed in brackets, e.g., [",$E($P(DHD(1),U,DDEF),1,(DV-6)),"]",! S %="Enter 1-"_DNUM_" to change default value, ^ to exit, RETURN to continue: " W %,$E(DDSPC,1,IOM-$L(%)-2)
 I $D(IOXY) S DX=$L(%),DY=IOSL-1 X IOXY
 I '$D(IOXY) F I=1:1:IOM-$L(%)-2 W $C(8)
 R X:DTIME S:'$T X=U,DTOUT=1 Q:X=U
 S X1="" I X=+X,X>0,X'>DNUM S J=$P(DNUM(X),U),N=$P(DNUM(X),U,2),X1=$P(^UTILITY($J,"DIT",J,N,0),U,3) G:'X1 PG I +^(0)=.01,$D(^UTILITY($J,"DITDINUM",J,N,0)) D ERD G PG
 I X1 S $P(^UTILITY($J,"DIT",J,N,0),U,3)='(X1-1)+1,DREDO=X,DX=5,DY=$P(DNUM(X),U,3)-1 D D1,D2 K DREDO G PG
 I $L(X) W $C(7) G PG
 Q
PG1 S DC=DC+1,DNUM=0 W:DIFF @IOF S DIFF=1 W DHD(0),?(IOM-29),DHD(9),"   PAGE ",DC
 S I=$S($D(DIMERGE):DDEF,1:0) F X1=1:1:DFL W ! W $E(DFL(X1),1,DV-1) W ?DV W:(I=1) "[" W $E($P(DHD(X1),U,1),1,DV-1) W:(I=1) "]" W ?(DV*2) W:(I=2) "[" W $E($P(DHD(X1),U,2),1,DV-1) W:(I=2) "]"
 W !,DDSH I $D(DIMUL) W !,?2,"NOTE: Multiples will be merged into the target record"
 Q
ERD W:'$D(IOXY) !! W $C(7) I $D(IOXY) S DX=0,DY=IOSL-1 X IOXY
 W "You must accept the default because this record is DINUMed!!",$E(DDSPC,1,IOM-62) I $D(IOXY) S DX=61,DY=IOSL-1 X IOXY
 R X:10 Q

DITC3
DITC3 ;SFISC/XAK-COMPARE FILE ENTRIES ;9/17/91  3:12 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=1:1:(IOSL-$Y-1) W !
 W "Enter RETURN to continue: " R X:DTIME S:'$T DTOUT=1
ASK Q:$D(DTOUT)  K DUOUT,DIRUT W @IOF,!,"OK.  I'M READY TO DO THE MERGE."
 S DIR(0)="S^P:PROCEED to merge the data;S:SUMMARIZE the modifications before proceeding;E:EDIT the data again before proceeding"
 S DIR("A")="ACTION" D ^DIR K DIR
 Q:$D(DIRUT)  I Y="E" D ^DITC2 Q:$D(DTOUT)  G ASK:X=U,DITC3:$D(^UTILITY($J,"DIT",U)),ASK
 S DIACT=Y,DNUM=0 D ACT Q:DIACT="P"  G:$D(DIRUT) ASK G DITC3
ACT ;
 I DIACT="S" D SUMHD
 S DIT1="" F K=0:0 Q:$D(DTOUT)  S DIT1=$O(^UTILITY($J,"DIT",DIT1)) Q:DIT1=""  S DIT2="" F K=0:0 Q:$D(DTOUT)  S DIT2=$O(^UTILITY($J,"DIT",DIT1,DIT2)) Q:DIT2=""  S X(0)=^(DIT2,0),%=$P(X(0),U,3) I %,DDEF'=% D EACH
 W !!,?2,"NOTE: Multiples will be merged into the target record"
 K DIT1,DIT2 Q
EACH ;
 I DIACT="S" G SUMEACH
 S DIE=DFF(1),DA=$P(DIT(DDEF),","),X2=$S($D(^UTILITY($J,"DITI",DIT1,DIT2,%)):^(%),'$D(^UTILITY($J,"DIT",DIT1,DIT2,%)):"@",1:^(%))
 S DR=+X(0)_"///"_X2 D ^DIE W "."
 K DR,DIE Q
SUMHD ;
 W @IOF,!,"SUMMARY OF MODIFICATIONS TO ",$P(DHD(DFL),U,DDEF),!,"FIELD",?DV,$S(DDEF=1:"OLD",1:"NEW")," VALUE",?(DV*2),$S(DDEF=1:"NEW",1:"OLD")," VALUE",!,DDSH
 Q
SUMEACH ;
 I $Y+5>IOSL K DIR S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)  D SUMHD
 K D S X2="",X(0)=$P(X(0),U,2) F I=1:1:2 S X(I)=$S($D(^UTILITY($J,"DIT",DIT1,DIT2,I)):^(I),1:"")
 D D20^DITC2
 Q

DITM
DITM ;SFISC/JCM(OHPRD)-FILE COMPARE AND MERGE DRIVER ;6/8/94  14:21
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
 D ASK ; Asks file, from, to, merge ,etc.
 G:$D(DITM("QFLG")) END
 D ^DITM2
END D EOJ ;----------->Cleanup
 Q  ;-------------->End of routine
 ;--------------------------------------------------------------------
 ;
ASK ;
 D ASKX
 K DITM,%H,DSUB,DMSG,DTO,DFL,DNUM,DDON
 K D001,DHD,^UTILITY($J,"DIT")
 K DITM("QFLG")
 D T^DICRW
 I Y<0 S DITM("QFLG")="" G ASKX
 S (DSUB,DIT,L)=0,DSUB(L)=DIC,DITC=1
 D ^DITM1
 G:$D(DITM("QFLG")) ASKX
 G:'$D(DITM("DFF")) ASK
Q1 ;
 W ! K DIR
 D BLD^DIALOG(8086,"","","DIR(""A"")"),BLD^DIALOG(9041,"","","DIR(""?"")")
 S DIR(0)="YO",DIR("B")=$P($$EZBLD^DIALOG(7001),U,2)
 D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT)) S DITM("QFLG")="" G ASKX
 S:Y=1 DITM("DIMERGE")=1
 G:'$D(DITM("DIMERGE")) Q6
 W ! F I=1,2 W !?4,I,?10,DTO(I,"X")
 K X,Y
Q2 ;
 W !
 S DIR(0)="N^1:2:0",DIR("?")="^S DMSG=3 D HELP^DITC0"
 S DIR("A",1)=" Note: Records will be merged into the entry selected for the default.",DIR("A")="WHICH ENTRY SHOULD BE USED FOR DEFAULT VALUES "
 D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT)) S DITM("QFLG")="" G ASKX
 I X'=2 S DITM("DIT(1)")=DIT(2),DITM("DIT(2)")=DIT(1)
 S DITM("DDEF")=2 W !,"   *** Records will be merged into "_DTO(X,"X"),!
 I X'=2
 K X,Y
Q3 ;
 W !
 S DIR(0)="Y"
 S DIR("A")="DO YOU WANT TO DELETE THE MERGED FROM ENTRY AFTER MERGING"
 S DIR("?")="If you enter NO the merged FROM entry will remain in this file"
 D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT)) S DITM("QFLG")="" G ASKX
 S:Y DITM("DELETE")=""
 K X,Y
 G:$D(DITM("SUB FILE")) Q6
Q4 ;
 W !
 S DIR(0)="Y"
 S DIR("A")="DO YOU WANT TO REPOINT ENTRIES POINTING TO THIS ENTRY"
 D ^DIR K DIR
 S:$D(DTOUT)!($D(DUOUT)) DITM("QFLG")=""
 G:$D(DTOUT)!($D(DUOUT)) ASKX
 S:Y DITM("REPOINT")=""
 G:'$D(DITM("REPOINT")) Q6
 K X,Y
Q5 ;
 W !
 S DIR(0)="PO^1:EMZ"
 S DIR("A")="ENTER FILE TO EXCLUDE FROM REPOINT/MERGE"
 S DIR("?")="Any file entered here will not be repointed or merged."
 F DITM=0:0 D ^DIR Q:$D(DIRUT)!(Y<1)  S DITM("EXCLUDE",+Y)=""
 K DIR
 I $D(DUOUT)!($D(DTOUT)) S DITM("QFLG")="" G ASKX
 K X,Y
Q6 ;
 W !
 S DIR(0)="YO",DIR("B")="NO"
 S DIR("A")="DO YOU WANT TO DISPLAY ONLY THE DISCREPANT FIELDS"
 S DIR("?")="^S DMSG=2 D HELP^DITC0"
 D ^DIR K DIR
 I $D(DTOUT)!($D(DUOUT)) S DITM("QFLG")="" G ASKX
 S:Y DITM("DDIF")=1
 K X,Y
ASKX ;
 K DFL,DIC,DISYS,DITC,DSUB,I,X,Y,DIPGM,DMSG,%,DIR,DIT,DFF,DTO,DDSP
 Q
EOJ ;
 K DITM,DMSG,DIRUT,L
 Q
 ;8086 NOTE: This option should be used only during non-peak hours...
 ;9041 If you merge two entries within a file that is pointed-to...
 ;7001 Yes^No

DITM1
DITM1 ;SFISC/JCM(OHPRD)-ASKS SUBFILE FOR COMPARE AND MERGE ;2/24/93  14:00 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ; When subfiles work will need to delete SUB+0 and uncomment SUB+1
 ;--------------------------------------------------------------------
START ;
SUB S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y
 ;S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA S:Y>0 DITM("SUBFILE")=+Y
ENTR I $D(DTOUT)!(X["^") S DITM("QFLG")="" G END
 K DIC S DIC(0)="AEQMZ",DIC=DSUB(0),DFL=1,DIT=DIT+1,DIT(DIT)="" W:DIT=1 !
E1 S DIC("A")=$E("        ",1,DFL-1*3)_$S(DIT=2:"   WITH ",1:"COMPARE ")_DFL(DFL)_": " I (DIT=2),(DFL=L),($P(DIT(1),",",1,L-1)=$P(DIT(2),",",1,L-1)) S DIC("S")="I Y-"_$P(DIT(1),",",L)
 D ^DIC K DIC("S"),DIC("A") I Y>0,$D(DSUB(DFL)),$D(DFL(DFL+1)) S DIC=DIC_+Y_","_DSUB(DFL),DIT(DIT)=DIT(DIT)_+Y_",",DFL=DFL+1 S %=$O(@(DIC_""""")")) G:%'=""&'% E1 S:%>0 ^(0)=U_DFF_U I %="" W !,"NO "_DFL(DFL) S (%,Y)=-1
 S:X=U DITM("QFLG")="" G:X=U!(Y=-1) END S DTO(DIT)=DIC_+Y_",",DTO(DIT,"X")=Y(0,0),DIT(DIT)=DIT(DIT)_+Y G:DIT=1 ENTR S DDSP=1
 S DITM("DFF")=DFF,DITM("DIT(1)")=DIT(1),DITM("DIT(2)")=DIT(2)
 S DITM("DIC")=DSUB(0)
 I $D(DITM("SUB FILE")),$D(DSUB(1)) S DITM("DSUB1")=$P(DSUB(1),",",1)
END ;
 Q

DITM2
DITM2 ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94  15:42
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; See DITMDOC for documentation
 ; Subfiles are not currently supported by the call to EN^DITM2
 ; until DITC can handle them.
 ;-------------------------------------------------------------------
START ;
EN ; Entry point
 L +@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
 L +@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
 K DMSG,DIRUT
 D:'$D(DITM("NON-INTERACTIVE")) DITC ; --->Sets up and calls DITC
 I $D(DMSG)!($D(DIRUT)) S DITM("QFLG")="" G END
 G:'$D(DITM("DIMERGE")) END
 D:'$D(DITM("SUB FILE")) DIT0 ; --->Sets up and calls DIT0
 D:$D(DITM("REPOINT"))&('$D(DITM("SUB FILE"))) REPOINT ;---->Merges
 ;---------------->other files that affect patient merge
 G:$D(DITM("QFLG")) END
 D:$D(DITM("DELETE")) DELETE ;----->Deletes MERGED entry
END L -@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
 L -@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
 D EOJ ;----------->Cleanup
 Q  ;-------------->End of routine
 ;----------------------------------------------------------------------
DITC ;
 ;***Will need to add set up for subfiles when it works******
 ;
 K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
 S DFF=DITM("DFF"),DIT(1)=DITM("DIT(1)"),DIT(2)=DITM("DIT(2)"),DIC=DITM("DIC")
 S:$D(DITM("DIMERGE")) DIMERGE=1
 S:$D(DITM("DDIF")) DDIF=DITM("DDIF")
 S:$D(DITM("DDEF")) DDEF=DITM("DDEF")
 S:$D(DITM("DDSP")) DDSP=1
 D EN^DITC
 K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
 Q
DIT0 ;
 W:'$D(DITM("NOTALK")) !!,"I will now merge all subfiles in this file ...",!,"This may take some time, please be patient."
 K DA
 S (DIT("T"),DIT("F"))=DITM("DIC")
 S (D0,DA("T"))=DITM("DIT(2)"),DA("F")=DITM("DIT(1)")
 D EN^DIT0 K D0,DA,DIC,DIK,DIT
 Q
REPOINT ;
 S DITMGMQF=0
 S:$D(DITM("NON-INTERACTIVE")) DITMGMRG("NOTALK")=1
 S:$D(DITM("PACKAGE")) DITMGMRG("PACKAGE")=DITM("PACKAGE")
 W:'$D(DITM("NOTALK")) !!,"I will now repoint all files that point to this entry ...",!,"This may take some time, please be patient."
 S DITMGMRG("FILE")=DITM("DFF"),DITMGMRG("FR")=DITM("DIT(1)"),DITMGMRG("TO")=DITM("DIT(2)")
 S:$D(DITM("NOTALK")) DITMGMRG("NOTALK")=""
 I $D(DITM("EXCLUDE")) F DITMI=0:0 S DITMI=$O(DITM("EXCLUDE",DITMI)) Q:'DITMI  S DITMGMRG("EXCLUDE",DITMI)=""
 D EN^DITMGMRG
 K DITMGMRG,DITMGMQF,DITMI
 Q
DELETE ;
 W:'$D(DITM("NOTALK")) !,"Deleting From entry"
 I $D(DITM("SUB FILE")) D DELSUB G DELETEX
 S DIK=DITM("DIC"),DA=DITM("DIT(1)") D ^DIK K DA,DIK
DELETEX Q
 ;
DELSUB ;
 S DA(1)=$P(DITM("DIT(1)"),",",1),DA=$P(DITM("DIT(1)"),",",2)
 S DIK=DITM("DIC")_DA(1)_","_DITM("DSUB1")_"," D ^DIK K DA,DIK
 Q
EOJ ;
 K DITM2,APMMD,DIC,X,Y
 Q

DITMGM1
DITMGM1 ;SFISC/EDE(OHPRD)-INTERACTIVE MERGE ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
START ;
 K DITMGMRG
 S DITMGMRG("GO")=0
 S DIC=1,DIC(0)="AEMQ" D ^DIC K DIC
 Q:Y<0
 S DITMGMRG("FILE")=+Y
 S DIC=DITMGMRG("FILE"),DIC(0)="AEMQ",DIC("A")="From entry: " D ^DIC K DIC
 Q:Y<0
 S DITMGMRG("FR")=+Y
 S DIC=DITMGMRG("FILE"),DIC(0)="AEMQ",DIC("A")="To entry: " D ^DIC K DIC
 Q:Y<0
 S DITMGMRG("TO")=+Y
 I DITMGMRG("FR")=DITMGMRG("TO") W !!,"From entry same as to entry!",!,$C(7) Q
 S DIC=1,DIC(0)="AEMQ",DIC("A")="Enter file to exclude from merge: " F  D ^DIC Q:Y<1  S DITMGMRG("EXCLUDE",+Y)=""
 K DIC
 S DIR(0)="Y",DIR("A")="Exclude files in affected packages",DIR("B")="NO"
 S DIR("?",1)="This routine normally relinks/merges all files.  Do you want to exclude"
 S DIR("?")="files that are part of a package that has its own merge routine?"
 D ^DIR K DIR
 Q:$D(DIRUT)
 I Y S DITMGMRG("PACKAGE")="",DITMGMRG("GO")=1 Q
 S DIR(0)="Y",DIR("A")="Merge only files in a specific package?",DIR("B")="NO"
 S DIR("?",1)="If you say NO you will merge all files pointing to the primary file."
 S DIR("?",2)="If you say YES you will be asked for a package file entry and only"
 S DIR("?")="merge the files in that package that point to the primary file."
 D ^DIR K DIR
 Q:$D(DIRUT)
 I 'Y S DITMGMRG("GO")=1 Q
 S DIC=9.4,DIC(0)="AEMQ" D ^DIC K DIC
 Q:Y<0
 S DITMGMRG("PACKAGE")=+Y
 S DITMGMRG("GO")=1
 Q

DITMGM2
DITMGM2 ;SFISC/EDE(OHPRD)-GENERAL RELINK/MERGE ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
START ;
 D INIT^DITMGM2B
 I $D(DITMGMQF) D EOJ Q
 D FILES
 D EOJ
 Q
 ;
FILES ; PROCESS ALL FILES/SUBFILES
 W:'$D(DITMGM2("NOTALK")) !!,"Merging entries",!
 F DITMGMFL=0:0 S DITMGMFL=$O(^UTILITY("DITMGMRG",$J,DITMGMFL)) Q:DITMGMFL=""  D FILE
 Q
 ;
FILE ; PROCESS ONE FILE/SUBFILE
 K DITMGMGM
 I $D(^DD(DITMGMFL,0,"UP")) S DITMGMMU=1 D ^DITMU2(DITMGMFL,.DITMGMGM,1) S DITMGMG=$P(DITMGMGM,"DA(",1),DITMGMGM=$P(DITMGMGM,"DA,",1) I 1
 E  S DITMGMMU=0,DITMGMG=^DIC(DITMGMFL,0,"GL")
 F DITMGMFD=0:0 S DITMGMFD=$O(^UTILITY("DITMGMRG",$J,DITMGMFL,DITMGMFD)) Q:DITMGMFD'=+DITMGMFD  S DITMGMFS=DITMGMF,DITMGMTS=DITMGMT D FIELD^DITMGM2A S DITMGMF=DITMGMFS,DITMGMT=DITMGMTS
 Q
 ;
ZTM ; ENTRY POINT FOR TASKMAN
 S DITMGM2("NOTALK")=1
 D SEARCH^DITMGM2B
 D EOJ
 Q
 ;
EOJ ;
 K %K,D1,D2,DA,DIC,DI,DIPGM,DQ,I,V
 K DITMGDA,DITMGMDI,DITMGMDN,DITMGMEC,DITMGMFD,DITMGMFL,DITMGMFG,DITMGMFS,DITMGMG,DITMGMGG,DITMGMI,DITMGML,DITMGMGM,DITMGMN,DITMGMNO,DITMGMPC,DITMGMTS,DITMGMTY,DITMGMTZ,DITMGMMU,DITMGMPF,DITMGMV,DITMGMX,DITMGMXR
 I $D(ZTQUEUED) S ZTREQ="@"
 E  K:$D(ZTSK) ^%ZTSK(ZTSK),ZTSK ; old Kernel
 Q

DITMGM2A
DITMGM2A ;SFISC/EDE(OHPRD),TKW-CONTINUATION OF ^DITMGM2 ;4/7/94  08:49
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
FIELD ; PROCESS ONE FIELD IN ONE FILE/SUBFILE
 S DITMGMPF=^UTILITY("DITMGMRG",$J,DITMGMFL,DITMGMFD)
 S DITMGMX=$P(^DD(DITMGMFL,DITMGMFD,0),U,4),DITMGMNO=$P(DITMGMX,";",1),DITMGMPC=$P(DITMGMX,";",2),DITMGMDI=$S(DITMGMFD=.01&($P(^(0),U,5,99)["DINUM"):1,1:0)
 S DITMGMV=$S($P(^DD(DITMGMFL,DITMGMFD,0),U,2)["V":1,1:0)
 I DITMGMV D
 . N % S %=$P(^DIC(DITMGMPF,0,"GL"),U,2) I %["""" S %=$$CONVQQ^DILIBF(%)
 . S DITMGMF=DITMGMF_";"_%,DITMGMT=DITMGMT_";"_% Q
 S DITMGMXR="",DITMGMX=0 F DITMGML=0:0 S DITMGMX=$O(^DD(DITMGMFL,DITMGMFD,1,DITMGMX)) Q:DITMGMX'=+DITMGMX  D  Q:DITMGMXR'=""
 . S DITMGMXR=$P(^(DITMGMX,0),U,2),DITMGMTY=$P(^(0),U,3),DITMGMTZ=$P(^(0),U,1)
 . I DITMGMTY="",'DITMGMMU  Q
 . I DITMGMTY="",DITMGMMU,DITMGMFL'=DITMGMTZ,'$D(^DD(DITMGMTZ,0,"UP")) Q
 . S DITMGMXR=""
 . Q
 K DA I DITMGMXR="" D NOXREF Q
 Q:'$D(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""")"))
 S DITMGMN="" F DITMGML=0:0 S DITMGMN=$O(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""",DITMGMN)")) Q:DITMGMN=""  D ENTRY:'DITMGMMU,MULTIPLE:DITMGMMU
 Q
 ;
MULTIPLE ; MULTIPLE WITH XREF TO FILE
 N DIXR,DICNT,DIDA,DIEND,DITMGZZZ
 S DITMGZZZ=DITMGMN,(DICNT,DIEND)=+$P(DITMGMGM,"DA(",2),DIDA(DICNT)=DITMGMN
 S DIXR(DICNT)=DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""","_DITMGMN_","
 S DICNT=DICNT-1
M2 I DICNT=DIEND S DITMGMN=DITMGZZZ Q
 S DIDA(DICNT)=$O(@(DIXR(DICNT+1)_+$G(DIDA(DICNT))_")"))
 I 'DIDA(DICNT) S DICNT=DICNT+1 G M2
 I DICNT=0 D  G M2
 . N DA F I=0:1:DIEND S DA(I)=DIDA(I)
 . S DA=DA(0) K DA(0)
 . N DIXR,DICNT,DIDA,DIEND D ENTRY
 . Q
 S DIXR(DICNT)=DIXR(DICNT+1)_DIDA(DICNT)_","
 S DICNT=DICNT-1 G M2
 ;
NOXREF ; FILES WITH NO REGULAR XREF ON POINTING FIELD
 I DITMGMDI,'DITMGMMU S DITMGMN=$S($D(@(DITMGMG_DITMGMF_")")):DITMGMF,1:"") D:DITMGMN ENTRY Q  ; If DINUM file xref not needed
 I '$D(@(DITMGMG_"0)")) W:'$D(DITMGM2("NOTALK")) !,"No Data Global:  ",DITMGMG Q
 I '$D(^%ZTSK)!($P(@(DITMGMG_"0)"),U,4)<3001) D SEARCH Q  ; If <= 3000 search gbl
 W:'$D(DITMGM2("NOTALK")) !,"No REGULAR xref on ",DITMGMFL,",",DITMGMFD," Merging entries for this file will",!,"now occur via Taskman in background!"
 ; SETUP CALL TO TASKMAN
 K DITMGMZT S:$D(ZTSK) DITMGMZT=ZTSK
 K ZTSAVE F %="DITMGMG","DITMGMGM","DITMGMNO","DITMGMPC","DITMGMF","DITMGMT","DITMGMFL","DITMGMFD","DITMGMDI","DITMGMXR","DITMGMMU","DITMGMV" S ZTSAVE(%)=""
 S ZTRTN="ZTM^DITMGM2",ZTDESC="PROCESS POINTER FIELD #"_DITMGMFD_" IN FILE #"_DITMGMFL_" FROM "_DITMGMF_" TO "_DITMGMT
 S ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK
 S:$D(DITMGMZT) ZTSK=DITMGMZT
 K DITMGMZT
 Q
 ;
SEARCH ; $O THRU DATA GBL
 D SEARCH^DITMGM2B
 Q
 ;
ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
 D ENTRY^DITMGM2B
 Q
QUOTES ;
 N %P,%Q S %W1="",%Q="""" F %P=1:1:$L(%W,%Q)-1 S %W1=%W1_$P(%W,%Q,%P)_%Q_%Q
 S %W1=%W1_$P(%W,%Q,$L(%W,%Q))
 Q

DITMGM2B
DITMGM2B ;SFISC/EDE(OHPRD),TKW-CONTINUATION OF DITMGM2 ;4/7/94  10:09
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
SEARCH ; $O THRU DATA GBL
 Q:'$O(@(DITMGMG_"0)"))
 W:'$D(DITMGM2("NOTALK")) !,"No REGULAR xref on ",DITMGMFL,",",DITMGMFD,".  ",+$P(^(0),U,4)," entries.  Searching data global."
 F DITMGMN=0:0 S DITMGMN=$O(@(DITMGMG_DITMGMN_")")) Q:DITMGMN'=+DITMGMN  D
 . I DITMGMMU D SEARCHM Q
 . I $D(^(DITMGMN,DITMGMNO)),$P(^(DITMGMNO),U,DITMGMPC)=DITMGMF D ENTRY
 . Q
 Q
 ;
SEARCHM ; $O THRU DATA GBL FOR MULTIPLES (TOP)
 S DITMGMDN=+$P(DITMGMGM,"DA(",2)
 S DA(DITMGMDN)=DITMGMN,DITMGDA(DITMGMDN)=DITMGMN
 S DITMGMGG=$P(DITMGMGM,"DA(",1)_"DA("_DITMGMDN_"),"
 S DITMGMDN=DITMGMDN-1
 NEW DITMGMN
 D SEARCHM2
 K DA,DITMGDA,DITMGMGG
 Q
 ;
SEARCHM2 ; MIDDLE (CALLED RECURSIVELY)
 I '$F(DITMGMGM,"DA("_DITMGMDN_"),") D SEARCHM3 Q
 S DITMGMGG=$P(DITMGMGM,",DA("_DITMGMDN_"),",1)_","
 F DITMGDA(DITMGMDN)=0:0 S DITMGDA(DITMGMDN)=$O(@(DITMGMGG_DITMGDA(DITMGMDN)_")")) Q:DITMGDA(DITMGMDN)'=+DITMGDA(DITMGMDN)  S DA(DITMGMDN)=DITMGDA(DITMGMDN) D SEARCHM4
 Q
 ;
SEARCHM3 ; BOTTOM
 D SETDA
 F DITMGMN=0:0 S DITMGMN=$O(@(DITMGMGM_DITMGMN_")")) Q:DITMGMN'=+DITMGMN  I $D(^(DITMGMN,DITMGMNO)),$P(^(DITMGMNO),U,DITMGMPC)=DITMGMF D ENTRY,SETDA
 Q
 ;
SETDA ; SET DA ARRAY
 K DA
 F I=1:1 Q:'$D(DITMGDA(I))  S DA(I)=DITMGDA(I)
 Q
 ;
SEARCHM4 ; RECURSE
 S DITMGMDN=DITMGMDN-1
 D SEARCHM2
 S DITMGMDN=DITMGMDN+1
 Q
 ;
ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
 D ENTRY^DITMGM2C
 Q
 ;
INIT ;
 K DITMGMQF
 K DITMGMRG("ERROR") S DITMGMEC=0
 S:$D(ZTQUEUED) DITMGM2("NOTALK")=1
 S:$D(ZTSK) DITMGM2("NOTALK")=1 ; old Kernel
 I '$D(DITMGMFL) S DITMGMQF=20 Q
 I 'DITMGMFL S DITMGMQF=20 Q
 I '$D(^DIC(DITMGMFL,0,"GL")) S DITMGMQF=20 Q
 S DITMGMFG=^("GL")
 I '$D(DITMGMF)!('$D(DITMGMT)) S DITMGMQF=21 Q
 I 'DITMGMF!('DITMGMT)!(DITMGMF=DITMGMT) S DITMGMQF=22 Q
 I '$D(@(DITMGMFG_DITMGMF_",0)")) S DITMGMQF=23 Q
 I '$D(@(DITMGMFG_DITMGMT_",0)")) S DITMGMQF=24 Q
 Q

DITMGM2C
DITMGM2C ;SFISC/EDE(OHPRD)TKW-CONTINUATION OF DITMGM2 ;5/11/94  15:16
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
 ;
 W:'$D(DITMGM2("NOTALK")) "."
 I DITMGMDI D DINUM Q  ; merge dinum entries
 ;
 ; ----- Transform DITMGMT
 S DITMGM("DITMGMT")=DITMGMT
 I 'DITMGMV S DITMGMT=$S(DITMGMFD=.01:"`",1:"/")_DITMGMT I 1
 E  S X=$P(DITMGMT,";",2),DITMGMT=$P(DITMGMT,";",1),X=+$P(@("^"_X_"0)"),U,2) D  Q:X=""  S DITMGMT=X_".`"_DITMGMT
 . S X=$O(^DD(DITMGMFL,DITMGMFD,"V","B",X,0))
 . Q:X=""
 . S X=$P(^DD(DITMGMFL,DITMGMFD,"V",X,0),U,4)
 . Q
 ; -----
 ;
 I DITMGMMU D ENTRYM I 1
 E  D ENTRYS
 S DITMGMT=DITMGM("DITMGMT") K DITMGM("DITMGMT")
 Q
 ;
ENTRYS ;
 ;
 S DITC="",DA=DITMGMN,D0=DA,DIE=DITMGMG,DR=DITMGMFD_"///"_DITMGMT
 D ^DIE K DA,DIE,DITC,DR,D0
 I $D(Y) S DITMGMEC=DITMGMEC+1,DITMGMRG("ERROR",DITMGMEC)="DIE"_U_DITMGMFL_U_DITMGMFD_U_DITMGMN_U_DITMGMF_U_DITMGMT
 Q
 ;
ENTRYM ; PROCESS ONE SUBFILE ENTRY
 S DITC="",DIE=DITMGMGM,DA=DITMGMN,DR=DITMGMFD_"///"_DITMGMT
 D ^DITMU1 ; Set D0, D1, etc.
 D ^DIE K DA,DIE,DITC,DR
 D KILL^DITMU1 ; Kill D0, D1, etc.
 I $D(Y) S DITMGMEC=DITMGMEC+1,DITMGMRG("ERROR",DITMGMEC)="DIE"_U_DITMGMFL_U_DITMGMFD_U_DITMGMN_U_DITMGMF_U_DITMGMT
 Q
 ;
DINUM ; DINUM FILE
 ; Move the 'from' entry to it's new IEN location.  Do a merge
 ; if there is already a record at that location.
 ;
 N DIDA,DIK,DITMFROM S DITMFROM=$S(DITMGMMU:DITMGMGM,1:DITMGMG)
 S $P(@(DITMFROM_DITMGMF_",0)"),U)=DITMGMT
 I '$D(@(DITMFROM_DITMGMT_",0)")) D
 . S @(DITMFROM_DITMGMT_",0)")=DITMGMT
 . S $P(@(DITMFROM_"0)"),U,3,4)=DITMGMT_"^"_($P(@(DITMFROM_"0)"),U,4)+1)
 . Q
 S DIDA=$S('DITMGMMU:",",1:$$IEN^DIEFU(.DA)),DIDA("F")=DITMGMF_DIDA,DIDA("T")=DITMGMT_DIDA
 D TRNMRG^DIT("M",DITMGMFL,"",DIDA("F"),DIDA("T"))
 S $P(@(DITMFROM_DITMGMF_",0)"),U)=DITMGMF
 D
 . N DA D DA^DIEFU(DIDA("T"),.DA) Q:$D(DIERR) 
 . K DIK S DIK=$$ROOT^DIQGU(DITMGMFL,DIDA("T")) Q:$D(DIERR)
 . N DIDA D IXALL^DIK Q
 D
 . N DA D DA^DIEFU(DIDA("F"),.DA) Q:$D(DIERR)
 . K DIK S DIK=$$ROOT^DIQGU(DITMGMFL,DIDA("F")) Q:$D(DIERR)
 . N DIDA D ^DIK Q
 Q

DITMGMRG
DITMGMRG ;SFISC/EDE(OHPRD)-RELINK/MERGE TWO ENTRIES BELOW POINTED TO FILE ;2/24/94  16:10
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; Merge two entries below pointed to file.  See ^DITMDOC.
 ;
START ;
 D ^DITMGM1
 I 'DITMGMRG("GO") D EOJ K DITMGMRG Q
 D EN
 K DITMGMRG
 Q
 ;
EN ; EXTERNAL ENTRY POINT
 D INIT^DITMGMRI
 Q:$D(DITMGMQF)
 D STACK
 S:$D(DITMGMRG("NOTALK")) DITMGM2("NOTALK")=1
 D ^DITMGM2 K DITMGM2("NOTALK")
 K ^UTILITY("DITMGMRG",$J)
 W:'$D(DITMGMRG("NOTALK")) !!,"Merge complete",!!
 D EOJ
 Q
 ;
STACK ;STACK ALL FILES POINTING TO POINTED TO FILE AND IF .01 FIELD
 ;POINTING AND DINUM, FILES POINTING TO POINTING FILE, AND SO ON.
 ;
 W:'$D(DITMGMRG("NOTALK")) !!,"Gathering files and checking 'PT' nodes"
 NEW DITMGFLE,DITMGPFL,DITMGPFD,DITMSKP
 K ^UTILITY("DITMGMRG",$J)
 S DITMGFLE=DITMGMRG("FILE")
 D FILES
 Q
 ;
FILES ; CALLED RECURSIVELY
 D PTCHK
 F DITMGPFL=0:0 S DITMGPFL=$O(^DD(DITMGFLE,0,"PT",DITMGPFL)) Q:DITMGPFL'=+DITMGPFL  D  I 'DITMSKP D FIELDS
 . S DITMSKP=0
 . I $D(DITMGMRG("EXCLUDE",DITMGPFL)) S DITMSKP=1 Q
 . ;I DITMGFLE=DITMGPFL S DITMSKP=1 Q
 . Q:'$D(DITMGMRG("PACKAGE"))
 . I DITMGMRG("PACKAGE") S:'$D(DITMGMRG("PACKAGE",DITMGPFL)) DITMSKP=1 Q
 . Q
 Q
 ;
FIELDS ;
 ;W:'$D(DITMGMRG("NOTALK")) "f"
 F DITMGPFD=0:0 S DITMGPFD=$O(^DD(DITMGFLE,0,"PT",DITMGPFL,DITMGPFD)) Q:DITMGPFD'=+DITMGPFD  D
 . S ^UTILITY("DITMGMRG",$J,DITMGPFL,DITMGPFD)=DITMGFLE
 . ;W:'$D(DITMGMRG("NOTALK")) $S($D(^DD(DITMGPFL,0,"UP")):"s",1:".")
 . I DITMGPFD=.01,'$D(^DD(DITMGPFL,0,"UP")),$P(^DD(DITMGPFL,.01,0),U,5,99)["DINUM" D RECURSE
 Q
 ;
RECURSE ;
 ;W:'$D(DITMGMRG("NOTALK")) "d"
 NEW DITMGFLE
 S DITMGFLE=DITMGPFL
 NEW DITMGPFL,DITMGPFD
 D FILES
 Q
 ;
PTCHK ; MAKE SURE "PT" CORRECT
 I '$D(DITMGMRG("NOTALK")) ;W $S(DITMGMRG("FILE")=DITMGFLE:"",1:"[")
 E  S DITMU4("NOTALK")=1
 S DITMU4FI=DITMGFLE
 F DITMU4PF=0:0 S DITMU4PF=$O(^DD(DITMU4FI,0,"PT",DITMU4PF)) Q:DITMU4PF=""  F DITMU4PD=0:0 S DITMU4PD=$O(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)) Q:DITMU4PD=""  D CHKIT^DITMU4
 K DITMU4FI,DITMU4L,DITMU4PF,DITMU4PD,DITMU4X,DITMU4("NOTALK")
 ;I DITMGMRG("FILE")'=DITMGFLE,'$D(DITMGMRG("NOTALK")) W "]"
 Q
 ;
EOJ ;
 K X,Y
 K %,DIPGM
 I $D(DITMGMQF) S DITMGMRG("QFLG")=DITMGMQF
 K DITMGMF,DITMGMFG,DITMGMFL,DITMGMQF,DITMGMT
 K AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
 I $D(ZTQUEUED) S ZTREQ="@" Q
 I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK Q  ; old Kernel
 I '$D(DITMGMRG("NOTALK")),$D(DITMGMRG("ERROR")) D EOJ2 K DITMGMRG("ERROR")
 Q
 ;
EOJ2 ; List errors
 W !!,"The following errors occurred during the merge: ",!
 F %=0:0 S %=$O(DITMGMRG("ERROR",%)) Q:%'=+%  W !,DITMGMRG("ERROR",%)
 W !
 K %
 Q

DITMGMRI
DITMGMRI ;SFISC/EDE(OHPRD)-INITIALIZTION FOR ^DITMGMRG ;11/18/94  15:45
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
INIT ;
 K DITMGMQF,DITMGMRG("QFLG")
 S:$D(ZTQUEUED) DITMGMRG("NOTALK")=1
 S:$D(ZTSK) DITMGMRG("NOTALK")=1 ; old Kernel
 I '$D(DITMGMRG("FILE")) S DITMGMQF=20 Q
 I 'DITMGMRG("FILE") S DITMGMQF=20 Q
 I '$D(^DIC(DITMGMRG("FILE"),0,"GL")) S DITMGMQF=20 Q
 S DITMGMFG=^("GL")
 S DITMGMFL=DITMGMRG("FILE")
 I '$D(DITMGMRG("FR"))!('$D(DITMGMRG("TO"))) S DITMGMQF=21 Q
 I 'DITMGMRG("FR")!('DITMGMRG("TO"))!(DITMGMRG("FR")=DITMGMRG("TO")) S DITMGMQF=22 Q
 I '$D(@(DITMGMFG_DITMGMRG("FR")_",0)")) S DITMGMQF=23 Q
 I '$D(@(DITMGMFG_DITMGMRG("TO")_",0)")) S DITMGMQF=24 Q
 S DITMGMF=DITMGMRG("FR")
 S DITMGMT=DITMGMRG("TO")
 I $D(DITMGMRG("EXCLUDE")) D EXCLFL
 I $D(DITMGMRG("PACKAGE")),'DITMGMRG("PACKAGE") D EXCLPK
 I $D(DITMGMRG("PACKAGE")),DITMGMRG("PACKAGE") D INCLPK
 Q
 ;
EXCLFL ; EXCLUDE SUBFILES FOR EXCLUDED FILES
 NEW F,S,X,V
 S V="EXCLUDE"
 F DITMGEFL=0:0 S DITMGEFL=$O(DITMGMRG("EXCLUDE",DITMGEFL)) Q:'DITMGEFL  S F=DITMGEFL D EXCSF
 K DITMGEFL
 Q
 ;
EXCLPK ; EXCLUDE FILES/SUBFILES FROM PACKAGES
 NEW F,S,X,V
 S V="EXCLUDE"
 F DITMGEPK=0:0 S DITMGEPK=$O(^DIC(9.4,"AMRG",$S('$G(DITMGMRG("TOP FILE")):DITMGMRG("FILE"),1:DITMGMRG("TOP FILE")),DITMGEPK)) Q:'DITMGEPK  F F=0:0 S F=$O(^DIC(9.4,DITMGEPK,4,"B",F)) Q:'F  S DITMGMRG("EXCLUDE",F)="" D EXCSF
 K DITMGEPK
 Q
 ;
INCLPK ; INCLUDE FILES/SUBFILES FOR PACKAGE
 NEW F,S,X,V
 S V="PACKAGE"
 S DITMGEPK=DITMGMRG("PACKAGE") F F=0:0 S F=$O(^DIC(9.4,DITMGEPK,4,"B",F)) Q:'F  S DITMGMRG("PACKAGE",F)="" D EXCSF
 K DITMGEPK
 Q
 ;
EXCSF ; EXCLUDE/INCLUDE SUBFILES FOR ONE FILE/SUBFILE (CALLED RECURSIVELY)
 F S=0:0 S S=$O(^DD(F,"SB",S)) Q:'S  S DITMGMRG(V,S)="" D EXCSF2
 Q
 ;
EXCSF2 ; RECURSION FOR SUBFILES WITHIN SUBFILES
 S X=S
 NEW F,S
 S F=X
 D EXCSF
 Q

DITMU1
DITMU1 ;SFISC/EDE(OHPRD)-SETS DA ARRAY FROM D0,D1 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; This routine sets the DA array from D0,D1 etc. or D0,D1
 ; etc. from the DA array.  If the variable DITMU1=2 it sets
 ; the DA array, otherwise it sets D0,D1 etc.
 ;
 ; The variable DITMU1 will be killed upon exiting this routine.
 ;
 ; The entry point KILL kills D0, D1, etc.
 ;
START ;
 NEW I,J
 I $G(DITMU1)=2 D D0DA
 E  D DAD0
 K DITMU1
 Q
 ;
DAD0 ;
 F I=1:1 Q:'$D(DA(I))  S I(99-I)=DA(I)
 S J=0 F I=0:1 S J=$O(I(J)) Q:J'=+J  S @("D"_I)=I(J)
 S @("D"_I)=DA
 Q
 ;
D0DA ;
 F I=0:1 Q:'$D(@("D"_I))  S J=I
 F I=0:1 S DA(J)=@("D"_I) S J=J-1 Q:J<1
 S DA=@("D"_(I+1))
 Q
 ;
KILL ; EXTERNAL ENTRY POINT - KILL D0, D1, ETC.
 NEW I
 F I=0:1 Q:'$D(@("D"_I))  K @("D"_I)
 Q

DITMU2
DITMU2(SUBFILE,GBL,FORM) ;SFISC/EDE(OHPRD)-RETURN SUBFILE GLOBAL REFERENCE ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; Given a subfile number and global reference form, this routine
 ; will return the global reference for a subfile in the form
 ; specified.
 ;
 ; FORM is optional but if passed should equal 1 or 2.  If FORM is
 ; not passed the default form will be 1.
 ;
 ;     FORM = 1 will be in the form ^GBL(DA(2),11,DA(1),11,DA,
 ;     FORM = 2 will be in the form ^GBL(D0,11,D1,11,D2,
 ;
 ; Formal list:
 ;
 ; 1) SUBFILE = subfile number (call by value)
 ; 2) GBL     = global reference (call by reference)
 ; 3) FORM    = global reference form (call by value)
 ;
 ; *** NO ERROR CHECKING DONE ***
 ;
START ;
 NEW FIELD,I,LVL,NODE,PARENT
 S GBL="",LVL=1
 D BACKUP
 S GBL=^DIC(PARENT,0,"GL")
 I $G(FORM)=2 D  S GBL=GBL_"D"_(I+1)_"," I 1
 . F I=0:1 S GBL=GBL_"D"_I_","_NODE(99-LVL)_",",LVL=LVL-1 Q:LVL=0
 . Q
 E  D  S GBL=GBL_"DA,"
 . F LVL=LVL:-1:0 Q:LVL=0  S GBL=GBL_"DA("_LVL_"),"_NODE(99-LVL)_","
 . Q
 Q
 ;
BACKUP ; BACKUP TREE (CALLED RECURSIVELY)
 S PARENT=^DD(SUBFILE,0,"UP")
 S FIELD=$O(^DD(PARENT,"SB",SUBFILE,""))
 S NODE(99-LVL)=$P($P(^DD(PARENT,FIELD,0),"^",4),";",1) S:NODE(99-LVL)'=+NODE(99-LVL) NODE(99-LVL)=""""_NODE(99-LVL)_""""
 I $D(^DD(PARENT,0,"UP")) S SUBFILE=PARENT,LVL=LVL+1 D BACKUP ; Recurse
 Q

DITMU3
DITMU3(FILE,FIELD,ROOT) ;SFISC/EDE(OHPRD)-GET XREFS FOR ONE FIELD IN ONE FILE/SUBFILE ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; Given a file/subfile number, a field number, and a variable
 ; from which to assign subscripted values, this routine will
 ; return the xrefs for the specified field.
 ;
 ; The returned xrefs will be subscripted from the ROOT as follows:
 ;
 ;  ROOT(FIELD,n)     = file/subfile^xref (e.g. 9000010^AC)
 ;  ROOT(FIELD,n,"K") = executable kill logic
 ;  ROOT(FIELD,n,"S") = executable set logic
 ;
 ; Formal list:
 ;
 ; 1)  FILE   = file or subfile number (call by value)
 ; 2)  FIELD  = field number (call by value)
 ; 3)  ROOT   = array root (call by reference)
 ;
START ;
 NEW Y
 F Y=0:0 S Y=$O(^DD(FILE,FIELD,1,Y)) Q:Y'=+Y  S ROOT(FIELD,Y)=^(Y,0),ROOT(FIELD,Y,"S")=^(1),ROOT(FIELD,Y,"K")=^(2)
 Q

DITMU4
DITMU4 ;SFISC/EDE(OHPRD)-FIX ALL "PT" NODES ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ; This routine fixes all "PT" nodes for files 1 through the
 ; highest file number in the current UCI.
 ;
START ;
 W:'$D(DITMU4("NOTALK")) !!,"This routine insures the ""PT"" node of each FileMan file is correct.",!
 W:'$D(DITMU4("NOTALK")) !!,"Now checking false positives.",!
 S U="^"
 S DITMU4FI=.99999999 F DITMU4L=0:0 S DITMU4FI=$O(^DD(DITMU4FI)) Q:DITMU4FI'=+DITMU4FI  I $D(^DD(DITMU4FI,0,"PT")) W:'$D(DITMU4("NOTALK")) !,DITMU4FI D FPOS
 W:'$D(DITMU4("NOTALK")) !!,"Now checking false negatives.",!
 D FNEG
 K DITMU4FI,DITMU4L
 W:'$D(DITMU4("NOTALK")) !!,"DONE",!
 Q
 ;
FPOS ; CHECK FOR FALSE POSITIVES
 S DITMU4PF="" F DITMU4L=0:0 S DITMU4PF=$O(^DD(DITMU4FI,0,"PT",DITMU4PF)) Q:DITMU4PF=""  S DITMU4PD="" F DITMU4L=0:0 S DITMU4PD=$O(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)) Q:DITMU4PD=""  D CHKIT
 K DITMU4PF,DITMU4PD,DITMU4X
 Q
 ;
CHKIT ;
 W:'$D(DITMU4("NOTALK")) "."
 I '$D(^DD(DITMU4PF)) W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF) Q
 I '$D(^DD(DITMU4PF,DITMU4PD,0)) W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD) Q
 S DITMU4X=$P(^DD(DITMU4PF,DITMU4PD,0),U,2)
 I DITMU4X["P",DITMU4X[DITMU4FI Q
 I DITMU4X["V",$D(^DD(DITMU4PF,DITMU4PD,"V","B",DITMU4FI)) Q
 W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)
 Q
 ;
FNEG ; CHECK FOR FALSE NEGATIVES
 S DITMU4FI=.99999999 F DITMU4L=0:0 S DITMU4FI=$O(^DD(DITMU4FI)) Q:DITMU4FI'=+DITMU4FI  W:'$D(DITMU4("NOTALK")) !,DITMU4FI S DITMU4FD=0 F DITMU4L=0:0 S DITMU4FD=$O(^DD(DITMU4FI,DITMU4FD)) Q:DITMU4FD'=+DITMU4FD  D:$D(^(DITMU4FD,0))#2 PTRCHK
 K DITMU4FI,DITMU4FD,DITMU4X,DITMU4I
 Q
 ;
PTRCHK ;
 S DITMU4X=$P(^(0),U,2)
 I DITMU4X["V" D PTRCHK2 Q
 Q:DITMU4X'["P"
 F DITMU4I=1:1:$L(DITMU4X)+1 Q:$E(DITMU4X,DITMU4I)?1N
 Q:DITMU4I>$L(DITMU4X)
 S DITMU4X=$E(DITMU4X,DITMU4I,999),DITMU4X=+DITMU4X
 Q:'DITMU4X
 Q:DITMU4X<1  ;*** DOES NOT MESS WITH FILE NUMBERS < 1 ***
 W:'$D(DITMU4("NOTALK")) "."
 Q:'$D(^DIC(DITMU4X))
 Q:'$D(^DD(DITMU4X,0))
 I '$D(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD)) W "|" S ^(DITMU4FD)=""
 Q
 ;
PTRCHK2 ; VARIABLE POINTER CHECK
 S DITMU4X="" F DITMU4L=0:0 S DITMU4X=$O(^DD(DITMU4FI,DITMU4FD,"V","B",DITMU4X)) Q:DITMU4X=""  I '$D(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD)) W:'$D(DITMU4("NOTALK")) "|" S ^(DITMU4FD)=""
 Q

DITP
DITP ;SFISC/GFT-TRANSFER POINTERS ;9/7/94  10:31 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D ASK Q:%-1  G PTS
 ;
ASK ;
 I '$D(^UTILITY("DIT",$J,0,1)) S %=2 Q
 S %=$O(^(1)),%Y=+^(1) S:%="" %=-1
U I $D(^DD(%Y,0,"UP")) S %Y=^("UP") G U
 W !,"SINCE THE "_$P("TRANSFERRED^DELETED",U,DH+1)_" ENTRY MAY HAVE BEEN 'POINTED TO'"
 W !,"BY ENTRIES IN THE '"_$P(^DIC(+%Y,0),U,1)_"' FILE," W:%>1 " ETC.,"
Q W !,"DO YOU WANT THOSE POINTERS UPDATED (WHICH COULD TAKE QUITE A WHILE)"
 S %=2 D YN^DICN Q:%  W !?4,"ANSWER 'YES' IF YOU THINK THAT THE ENTRY WHICH YOU HAVE JUST "_$P("MOVED^DELETED",U,DH+1),!?4,"MAY BE 'POINTED TO' BY SOME POINTER-TYPE FIELD VALUE SOMEWHERE",! G Q
 ;
PTS ;
 D WAIT^DICD K IOP
P K DR,D,DL,X S (BY,FR,TO)="",X=$O(^UTILITY("DIT",$J,0,0))
 I X="" K ^UTILITY("DIT",$J),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L Q
 S Y=^(X),L=$P(Y,U,2),DL=1
 S DL(1)=L_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):"_$S($P(Y,U,3)'["V":"+",1:"")_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^DITP" K ^(X)
 S L=$P(^DD(+Y,L,0),U,4),%=$P(L,";",2),L=""""_$P(L,";",1)_"""",DHD=$P(^(0),U) I % S %="$P(^("_L_"),U,"_%
 E  S %="$E(^("_L_"),"_+$E(%,2,9)_","_$P(%,",",2)
 S L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$S($P(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D"
UP S (D(DL),%)=+Y I $D(^DD(%,0,"UP")) S DL=DL+1,Y=^("UP"),(DL(DL),%)=$O(^DD(Y,"SB",%,0))_"///",X(DL)=""""_$P($P(^DD(Y,+%,0),U,4),";")_"""",BY=+%_","_BY G UP
 S DHD=$O(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed" G P:'$D(^DIC(%,0,"GL")) S DIC=^("GL"),Y="S X=$S('$D("_DIC_"D0,"
 F X=0:1:DL-1 S DR(X+1,D(DL-X))=DL(DL-X) S:X Y=Y_X(DL+1-X)_",D"_X_","
 S DIA("P")=%,%=$L(BY,",") I %>2 S BY=$P(BY,",",%-2)_",.01,"_BY
 S BY=BY_Y_L_X_")",L=0,FLDS="",DISTOP=0,DHIT="G LOOP^DIA2",%ZIS=""
 I $G(DIFIXPT)=1 D EN1^DIP G P
 D EN1^DIP
 S IOP=IO G P
 ;
PTRPT Q:'$G(DIFIXPTC)  N I,J,X
 F I=1:1:DL S J="" F  S J=$O(DR(I,J)) Q:J=""  I DR(I,J)["///" S X=$P($G(DR(I,J)),"///",1) I X]"" D
 . S ^TMP("DIFIXPT",$J,DIFIXPTC)=^TMP("DIFIXPT",$J,DIFIXPTC)_$S(I>1:" entry:"_$S(I=DL:$G(DA),1:$G(DA(DL-I))),1:"")_$S(I=DL:"   field:",1:"   mult.fld:")_X
 . Q
 Q

DITR
DITR ;SFISC/GFT-FIND FLDS TO XRF ;8/13/96  13:35;
 ;;21.0;VA FileMan;**6,25**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S (DFL,DTL)=DFL-1 Q:'$D(DFN(DFL))
N S @("DFN(DFL)=$O("_DFR(DFL)_"DFN(DFL)))")
 I DFN(DFL)]"",$D(^(DFN(DFL)))#2 S Z=^(DFN(DFL)),A="" D:$G(DIFRFRV) SFRV1 G NS
 G DITR:DFN(DFL)="",1:DFL#2,DITR:$D(^(DFN(DFL),0))-1 S Z=^(0),X="D"_(DFL\2),@X=DFN(DFL) I DTO,$D(DSC(DDF(DFL+1))) X DSC(DDF(DFL+1)) E  G N
 D ^DITR1 G N:A D D,SFRV1:$G(DIFRFRV)
NS S A=$O(^DD(DDF(DFL),"GL",DFN(DFL),A)) G N:A=""
 S W=$O(^(A,0)) S:W="" W=-1 G:$G(DIFRDKP) NS:$D(@DIFRSA@("^DD",DIFRFILE,DDF(DFL),W)) I A S Y=$P(Z,U,A) G NS:Y=""
 E  S Y=$E(Z,+$E(A,2,9),$P(A,",",2)) F %=$L(Y):-1 Q:" "'[$E(Y,%)  G NS:'% S Y=$E(Y,1,%-1)
 I DTO G NS:'$D(^UTILITY("DITR",$J,DDF(DFL),W)) S B=^(W),DTN(DTL)=$P(B,U,2)
 E  S B=A,DTN(DTL)=DFN(DFL)
 S X="" I @("$D("_DTO(DTL)_"DTN(DTL)))#2") S X=^(DTN(DTL))
 I 'B D  G NS
 .S W=$E(B,2,9),B=$P(B,",",2)
 .I $E(X,+W,B)'?." "&DKP D:$G(DIFRFRV) KFRV1 Q
 .S %=$E(X,B+1,999),V=W-$L(X)-1,^(DTN(DTL))=$E(X,0,W-1)_$J("",$S(V>0:V,1:0))_Y S:%'?." " ^(DTN(DTL))=^(DTN(DTL))_$J("",B+1-W-$L(Y))_%
 .I $G(DIFRFRV) D SFRVL
 .Q
 I DKP,$P(X,U,B)]"" D:$G(DIFRFRV) KFRV1 G NS
P S $P(^(DTN(DTL)),U,B)=Y D:$G(DIFRFRV) SFRVL G NS
 ;
1 G N:$O(^(DFN(DFL),0))'>0 S Z=$O(^DD(DDF(DFL),"GL",DFN(DFL),0,0)) G N:Z'>0 I DTO G N:'$D(^UTILITY("DITR",$J,DDF(DFL),Z)) S B=^(Z)
 D D S Y=$P(^DD(DDF(DFL-1),Z,0),U,2),DDF(DFL+1)=+Y I DTO S Y=$P(B,U,3),X=""""_$P(B,U,2)_""","
 S DDT(DTL)=+Y,DTO(DTL)=DTO(DTL-1)_X S:$G(DIFRDKP) DIFRX=$D(@DIFRSA@("^DD",DIFRFILE,+Y)) I @("'$D("_DTO(DTL)_"0))") G:$G(DIFRDKP) DITR:DIFRX S ^(0)=U_Y
 G N
 ;
SFRV1 S DIFRFRV1=$P($NA(@("DIFRFRV(D0,"_$P(DFR(DFL),DFR(1),2,255)_""""_DFN(DFL)_""")")),"DIFRFRV(",2,255),$E(DIFRFRV1,$L(DIFRFRV1))=""
 Q
SFRVL Q:'$D(@DIFRSA@("FRV1",DIFRFILE,DIFRFRV1))
 S @DIFRSA@("FRVL",DIFRFILE,DIFRFRV1)=$NA(@(DTO(DTL)_""""_DFN(DFL)_""")"))
 Q
KFRV1 K @DIFRSA@("FRV1",DIFRFILE,DIFRFRV1,B)
 Q
 ;
D S DTL=DFL+1
 S X=""""_DFN(DFL)_""",",DFR(DFL+1)=DFR(DFL)_X,DFL=DFL+1,DFN(DFL)=0 Q
 ;
F ;
 S A=1,@("Z="_DIK_"D0,0)") W !,$P(^(0),U,1) G I:'DTO!'$D(DITF)
 S Z=$P(DITF,";",1) I Z=" " S Z=D0 G I
 Q:'$D(^(Z))  S X=$P(DITF,";",2) I X S Z=$P(^(Z),U,X) G I
 S Z=$E(^(Z),+$E(X,2,9),+$P(X,",",2))
I ;
 S DFL=0,DTL=0,DA=D0 D ^DITR1 I $G(DIFRSA)]"" S:$D(@DIFRSA@("TMP"))>9 DIFRND0=Y
 Q:A
GO ;
 S DFL=1,DTL=1,DFN(1)=-1 D N

DITR1
DITR1 ;SFISC/GFT-FIND ENTRY MATCHES ;10:18 AM  17 May 1994
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S W=DMRG,X=$P(Z,U),%=DFL\2,Y=@("D"_%),A=1 S:$G(DIFRDKP) DIFRNOAD=$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01,0))
 G WORD:$P(^DD(DDT(DTL),.01,0),U,2)["W",Q:X="",ON:'W
 K DINUM I ^(0)["DINUM" S V=+Y G:$P(^(0),U,2)["P" DINUM S V=X,DA=Y,Y=0,D0=$S($D(D0):D0,$D(DFR):DFR,1:"") D DA X $P(^(0),U,5,99) S X=V,Y=DA Q:'$D(DINUM)  S (Y,V)=DINUM K DINUM G DINUM
 S V=0 D:'$D(DISYS) OS^DII
B I '$D(^DD(DDT(DTL),0,"IX","B",DDT(DTL),.01)) F A=1:1 S V=$O(@(DTO(DTL)_V_")")) G NEW:V'>0 I $D(^(V,0)),$P(^(0),U)=X D MATCH G OLD:'$D(A) S A=1
 S %=+$P(^DD("OS",DISYS,0),U,7) S:'% %=63
 S V=$S($O(@(DTO(DTL)_"""B"",$E(X,1,%),V)"))>0:$O(^(V)),1:$O(@(DTO(DTL)_"""B"",$E(X,1,30),V)"))) G NEW:V'>0
 I $D(@(DTO(DTL)_V_",0)")),$P(^(0),X)="" D MATCH G OLD:'$D(A)
 G B
 ;
DA Q:'%  S DA(%)=@("D"_Y),Y=Y+1,%=%-1 G DA
 ;
DINUM I @("$D("_DTO(DTL)_"Y))") G:'DKP OLD D MATCH G:'$D(A) OLD S A=1 G Q
 G ADD
 ;
NEW S W=0
ON I @("$D("_DTO(DTL)_"Y))") G OLD:W S Y=Y+1 G ON
ADD G:$G(DIFRDKP) Q:DIFRNOAD S @("V="_DTO(DTL)_"0)"),^(0)=$P(V,U,1,2)_U_Y_U_($P(V,U,4)+1),^(Y,0)=X
OLD S DTO(DTL+1)=DTO(DTL)_Y_",",DTN(DTL+1)=0,A=0
Q Q
 ;
WORD I $G(DIFRDKP) Q:$D(@DIFRSA@("^DD",DIFRFILE,DDT(DTL),.01))
 S @("V=$O("_DTO(DTL)_"0))") X:V'>0!'DKP "K "_$E(DTO(DTL),1,$L(DTO(DTL))-1)_") S:$D("_DFR(DFL)_"0)) "_DTO(DTL)_"0)=^(0)","F V=0:0 S V=$O("_DFR(DFL)_"V)) Q:V'>0  S:$D(^(V,0)) "_DTO(DTL)_"V,0)=^(0)" S (DFL,DTL)=DFL-1 Q
 ;
MATCH S A=1 I Y'=V,$D(^DD(DDT(DTL),.001,0)) Q
 S Y=V,I=.01
I S I=$O(^DD(DDT(DTL),0,"ID",I)) I I'>0 G:$G(DIFRDKPR)&($G(DIFRDKPD))&('DTL) REPLACE K A Q
 G I:'$D(^DD(DDT(DTL),I,0)) K B D P G I:W="" S B=W
 I DTO S A=$P(A,";",2)_U_$P(A,";",1) F %=0:0 S %=$O(^UTILITY("DITR",$J,DDF(DFL+1),%)) G I:%'>0 Q:^(%)=A
 E  S %=I
 G I:'$D(^DD(DDF(DFL+1),%,0)) D P G I:W="",I:W=B
 S Y=@("D"_(DFL\2)) Q
 ;
P S A=$P(^(0),U,4),%=$P(A,";",2),W=$P(A,";",1) I @("'$D("_$S('$D(B):DTO(DTL)_"Y,",DFL:DFR(DFL)_"DFN(DFL),",1:DFR(1))_"W))") S W="" Q
 I % S W=$P(^(W),U,%)
 E  S W=$E(^(W),+$E(W,2,9),$P(W,",",2))
 I W'?.UNP F %=1:1:$L(W) I $E(W,%)?1L S W=$E(W,0,%-1)_$C($A(W,%)-32)_$E(W,%+1,999)
 Q
 ;
REPLACE ;
 N DA,DIK
 K @DIFRSA@("TMP")
 I DIFRDKPS M @DIFRSA@("TMP",DIFRFILE,Y)=@(DTO(DTL)_Y_")")
 S DA=Y,DIK=DIFROOT
 N %,A,B,D0,DDF,DDT,DFL,DFR,DINUM,DKPKDMGR,DTL,DTN,DTO,I,W,X,Y,Z
 D ^DIK
 S DIFRDKPD=0,V="A"
 Q

DIU
DIU ;SFISC/GFT-UTILITY FUNCTIONS ;10/11/94  16:01
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K DIU
0 S DIC="^DOPT(""DIU"","
 G OPT:$D(^DOPT("DIU",10)) S ^(0)="UTILITY OPTION^1.01" K ^("B")
 F X=1:1:10 S ^DOPT("DIU",X,0)=$P($T(@X),";;",2)
 S DIK=DIC D IXALL^DIK S ^DOPT("DICR",0)="TYPE OF INDEXING^1.01"
 F X=1:1:7 S ^DOPT("DICR",X,0)=$P("REGULAR^KWIC^MNEMONIC^MUMPS^SOUNDEX^TRIGGER^BULLETIN",U,X)
 S DIK="^DOPT(""DICR""," D IXALL^DIK G 0
OPT ;
 S DIC(0)="AEQIZ" S:DUZ(0)'="@" DIC("S")="I Y-5"
 D ^DIC G Q:Y<0 S DI=Y D EN G 0
 ;
EN ;
 D D^DICRW G Q:Y<0 I '$D(DIC) D DIE^DIB G Q:'$D(DG) S DIC=DG
 S DIU=DIC,DIU(0)="EDT" K DICS
 K DIC,I,J S Y=DI,N=0,DI=+$P($G(@(DIU_"0)")),U,2),J(0)=DI,I(0)=DIU
 I 'DI W $C(7),!,"Missing or incomplete global node "_DIU_"0)",! G Q
 K DDA I $D(^DD(DI,0,"DDA")),^("DDA")["Y" S DDA=""
 D @+Y W !!
Q K %,DIUF,DG,DGG,DIC,DIU,DJJ,DIK,DI,DA,I,J,X,Y,DICD,DICDF,DDA,DIFLD,DTOUT,DUOUT Q
 ;
1 ;;VERIFY FIELDS
 G ^DIV
 ;
2 ;;CROSS-REFERENCE A FIELD
 S X="CW" D DI Q:Y<.002  G ^DICD
 ;
3 ;;IDENTIFIER
 S X="CW.01" D DIAX Q:'$T  D DI Q:Y<0  G 3^DIU3
 ;
4 ;;RE-INDEX FILE
 G 4^DIU1
 ;
5 ;;INPUT TRANSFORM (SYNTAX)
 S X="W" D DIAX Q:'$T  D DI Q:Y<0  G 5^DIU31
 ;
6 ;;EDIT FILE
 G 6^DIU0
 ;
7 ;;OUTPUT TRANSFORM
 S X="CW" D DI Q:Y<0  G O^DIU31
 ;
8 ;;TEMPLATE EDIT
 G 0^DIBT
 ;
9 ;;UNEDITABLE DATA
 S X="WC" D DIAX Q:'$T  D DI Q:Y<0  G 9^DIU31
 ;
10 ;;MANDATORY/REQUIRED FIELD CHECK
 G ^DIVRE
 ;
11 ;;SPECIFIER
 S X="CW",N=0 D DI Q:Y<0  G ^DIU4
DI ;
 S DIC(0)="ZQEAI"
D ;
 S DIC="^DD("_DI_",",DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":""  (word-processing)"",1:""  (multiple)"")"
 S DIC("S")="S %=$P(^(0),U,2) I 1"_$P(",%'[""C""",U,X["C")_$P(",$P(^DD(+%,.01,0),U,2)'[""W""",9,X["W")_$P(",Y-.01",U,X[.01),DA=X
 D ^DIC K DIC("S") I Y>0,$P(Y(0),U,2) S N=N+1,X=$P($P(Y(0),U,4),";",1),DI=$E("""",+X'=X),I(N)=DI_X_DI,(DI,J(N))=+$P(Y(0),U,2),X=DA G DI
 Q
DIAX I '$D(^DD(DI,0,"DI"))!($P($G(^("DI")),U)'["Y")!($P($G(^("DI")),U)["Y"&'$P(@(^DIC(DI,0,"GL")_"0)"),U,4))
 W:'$T !!,$C(7),"THIS DATA DICTIONARY CHANGE IS NOT ALLOWED ON AN ARCHIVE FILE!"
 Q

DIU0
DIU0 ;SFISC/XAK-EDIT/DELETE A FILE ;7/2/93  4:08 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIPZ ;
 D PZ,DIEZ Q
PZ ;
 S DIU2=$S($D(J(0))#2:J(0),1:"") N DIC,C,F,I,J,M,O,Q,S,T,V,W,Y
 F DIU0=0:0 S DIU0=$O(^DIPT("AF",DI,DA,DIU0)) Q:DIU0'>0  K ^(DIU0),^DIPT(DIU0,"ROU") S DMAX=^DD("ROU"),X=^DIPT(DIU0,"ROUOLD"),Y=DIU0,DIU1=DI D EN^DIPZ S DI=DIU1
 S J(0)=DIU2 D DT Q
 ;
DIEZ N DL,DH,DQ,DIE,DIC,DNM,DR,M,T,F,Q,Y F DIU0=0:0 S DIU0=$O(^DIE("AF",DI,DA,DIU0)) Q:DIU0'>0  K ^(DIU0),^DIE(DIU0,"ROU") S DMAX=^DD("ROU"),X=^DIE(DIU0,"ROUOLD"),Y=DIU0,DIU1=DI D EN^DIEZ S DI=DIU1
DT I $D(^DD(DI,DA)) S:$S($D(^DIC(J(0),"%A")):$P(^("%A"),U,2),1:0)-DT ^DD(DI,DA,"DT")=DT
 K DIU0,DIU1,DIU2 W ! Q
 ;
EN ;
 I DIU,DIU(0)["S" G SUB
 I DIU,$D(^DIC(DIU,0,"GL")) S DIU=^("GL")
 G Q:DIU S DIK="^DIC(",DG=$S($D(@(DIU_"0)")):^(0),1:""),(A,DA)=+$P(DG,U,2)
 G Q:'A D ^DIK G 61
6 S DR=".01:10;"_$P(20,U,$S($D(^DIC(200,0)):^(0)["NEW PERSON",$D(^DIC(3,0)):^(0)["USER"!(^(0)["EMPLOY"),1:0))
 S DIE=1,(A,DA)=DI,DIER=1 D ^DIE K DIER G N^DIU2:$D(DA)
61 S DQ(A)=0 G:DIU(0)'["D" 63
 S Y=$L(DIU),Y=$E(DIU,1,Y-1)_$E(")",$E(DIU,Y)=","),%=0
 I DIU(0)["E" W !?3,"OK TO DELETE THE '"_Y_"' GLOBAL" D YN^DICN K:%=1 @Y G 63
 K @Y
63 W:DIU(0)["E" !?3,"Deleting the DATA DICTIONARY..." D KDD^DICATT4
 Q:DIU(0)["S"  G Q:DIU(0)'["T"
 F DIK="^DIE(","^DIPT(","^DIBT(" K @(DIK_"""F""_A)") W:DIU(0)["E" !?3,"Deleting the "_$P(^(0),U)_"S..." S DA=.9 F  S DA=$O(@(DIK_"DA)")) Q:DA'>0  I $D(^(DA,0)) S %=$P(^(0),U,4) I %=""!'$D(^DD(+%)) W:DIU(0)["E" "." D ^DIK
 D FORM^DDSDEL(A,DIU(0)["E")
Q K A,DA,DG,DIK,DQ Q
 ;
SUB G Q:'$D(^DD(DIU,0,"UP")) S DA(1)=^("UP"),DQ(DIU)=0
 I DIU(0)'["D" S A=DA(1) D 63 S A=DIU G SE
 S D0=DIU,S=";",Q=""""
 F I=1:1 Q:'$D(^DD(DIU,0,"UP"))  S A=^("UP"),%=$O(^DD(A,"SB",DIU,0)) Q:%=""  Q:'$D(^DD(A,%,0))#2  S %(I)=$P($P(^(0),U,4),S),DIU=A S:+%(I)'=%(I) %(I)=Q_%(I)_Q I I=1 S (O,M)=^(0)
 S DICL=I-2 F I=1:1:DICL S I(I)=%(DICL-I+1)
 S I(0)=^DIC(DIU,0,"GL") K % D 63 S A=D0 D EN^DICATT4
SE S DIK="^DD("_DA(1)_",",DA=$O(^DD(DA(1),"SB",A,0)) D ^DIK:DA
 K D0,DICL,E,I,M,O,Q,S,T,X,Y G Q

DIU1
DIU1 ;SFISC/GFT-REINDEX A FILE ;2/24/93  14:13 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
 W !! K ^UTILITY("DIK",$J),X S DIK=DIU,X=0 D DD^DIK S DW=0,DIUF=DI K DU,DV
DW S DW=$O(^UTILITY("DIK",$J,DW)),DV=0 S:DW="" DW=-1
 I DW>0 S DU=0 F  S DV=$O(^UTILITY("DIK",$J,DW,DV)),DH=0 G DW:DV="" S Y=0 F  S DH=$O(^UTILITY("DIK",$J,DW,DV,DH)) Q:DH=""  S Y=^(DH),X=X+1,X(X)=Y,X(X,0)=DW_U_DV S:$P(Y,U,3)=""&'Y&$D(^(DH,0)) X(X)=^(0)
 K ^UTILITY("DIK",$J) G DD:'X,ONE:X>1
ALL W "OK, ARE YOU SURE YOU WANT TO KILL OFF THE EXISTING "_$S(X=1:$P(^DD(+X(1,0),$P(X(1,0),U,2),0),U,1)_" INDEX",1:X_" INDICES") S %=2
 D YN^DICN G:%-1 NO:%,Q W !,"DO YOU THEN WANT TO 'RE-CROSS-REFERENCE'" D YN^DICN G NO:%<1 S N=%=1 D WAIT^DICD
 F X=X:-1:1 S %=$P(X(X),U,2) I %]"",+X(X)=DI K @(DIK_"%)") K:$P(X(X),U,3)'="MUMPS" X(X)
 S DIK(0)="AB" I $O(X(0))'="" S X=2,(DA,DCNT)=0 D DD^DIK,CNT^DIK1
 K X I N W !,$C(7),"FILE WILL NOW BE 'RE-CROSS-REFERENCED'..." H 5 D DD S DIK=^DIC(DIUF,0,"GL") D IXALL^DIK
 K DIK,DIC Q
 ;
DD S DIK="^DD(DI,",DA(1)=DI K ^DD(DI,"B"),^("GL"),^("IX"),^("RQ"),^("GR"),^("SB")
 W "." D IXALL^DIK:$D(^(0))#2 S DI=$O(^DD(DI)) S:DI="" DI=-1 I DI>0,DI<$O(^DIC(DIUF)) G DD
 Q
 ;
ONE S %=2 W "THERE ARE "_X_" INDICES WITHIN THIS FILE",!,"DO YOU WISH TO RE-CROSS-REFERENCE ONE PARTICULAR INDEX" D YN^DICN W ! I %-1 G ALL:%=2,NO:%,Q
 K X S X="CW" D DI^DIU G NO:Y<0 S (DA,DL)=+Y,DICD="RE-CROSS-REFERENCE" D CHIX^DICD G NO:'DICD
 S X=$P(I,U,2)
 W !,"ARE YOU SURE YOU WANT TO DELETE AND RE-CROSS-REFERENCE "_$S(X]"":"THE '"_X_"' INDEX",1:"THIS TRIGGER") S %=2 D YN^DICN G NO:%-1
 G IND:X="" F %=0:0 S %=$O(^DD(+I,0,"IX",X,%)) Q:%=""  F %Y=0:0 S %Y=$O(^DD(+I,0,"IX",X,%,%Y)) Q:%Y=""  I %Y-DA!(%-DI) G IND
 I +I=DIUF,$P(I,U,3)="",X]"" K @(DIK_"X)") G REDO
IND S X=^DD(J(N),DA,1,DICD,2) D DD^DICD:"Q"'[X S DIU=^DIC(DIUF,0,"GL")
REDO S X=^DD(J(N),DL,1,DICD,1) D DD^DICD:"Q"'[X W $C(7),"    ...DONE!" Q
 ;
Q F I=1:1:X W !,"FIELD " S %=X(I,0),J=$P(%,U,2) W J_" ('"_$P(^DD(+%,J,0),U,1)_"'" W:%-DI ", "_$O(^DD(+%,0,"NM",0))_" SUBFILE" W ") IS ",$S(X(I):"'"_$P(X(I),U,2)_"' INDEX",1:$P(X(I),U,3)) D UP
 G 4
UP I X(I),X(I)-DI S %=$D(^DD(+X(I),0,"UP")) W " OF "_$O(^("NM",0))_" "_$P("SUB",U,%>0)_"FILE" Q
 S %=+$P(X(I),U,4),(%F,Y)=+$P(X(I),U,5) I %,$D(^DD(%,Y,0)) W:$X>44 ! W " OF " D WR^DIDH
 Q
 ;
NO W !?7,$C(7),"<NO ACTION TAKEN>" K DICD,X,DH
 Q

DIU2
DIU2 ;SFISC/XAK-EDIT FILE ;7/25/94  14:39
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
N S X=$P(^DIC(DA,0),U,1),D=@(DIU_"0)"),^(0)=X_U_$P(D,U,2,9) K ^DD(+$P(D,U,2),0,"NM") S ^("NM",X)="" Q:$D(Y)
VR ;S DIR("A")="VERSION",DIR(0)="FO^1^I X'=""@"",X'?.N.1"".""1.N,X'?.N.1"".""1.N1U1.N K X"
 ;S DIR("?")="Enter the number that describes the current version of this data dictionary"
 ;S:$D(^DD(DA,0,"VR")) DIR("B")=^("VR")
 ;S DIR("??")="^W !!,""This number can be in either the old format (1.0, 16.04, etc.)"",!,""or the new format (18.0T4, 19.1V2, etc.)."""
 ;D ^DIR G Q:$D(DTOUT)!$D(DUOUT) K DIRUT
 ;I X="@" K ^DD(DA,0,"VR") W "   Deleted" S X=""
 ;I X]"" S ^DD(DA,0,"VR")=X
 ;
 I DUZ(0)]"" F DR=1:1:6 S D=$P("DD^RD^WR^DEL^LAYGO^AUDIT",U,DR),Y=$S($D(^DIC(DA,0,D)):^(D),1:"") D RW G Q:X=U
 S X=$S($D(^("AUDIT")):^("AUDIT"),1:"")
 I X]"",DUZ(0)'="@" F Z=1:1:$L(X) Q:DUZ(0)[$E(X,Z)  Q:Z=$L(X)
 S DIU(0)=$P(@(DIU_"0)"),U,2) K DIR
A ;S DIR("A")="AUDIT THE ENTIRE FILE",DIR(0)="YO",DIR("B")=$S(DIU(0)["a":"YES",1:"NO")
 ;S DIR("??")="^W !!?5,""Answer YES only if you want to audit the data changes for every field"",!?5,""in this file."""
 ;D ^DIR G Q:$D(DTOUT)!$D(DUOUT),DDA:X=""
 ;I Y,DIU(0)'["a" S DIU(0)=DIU(0)_"a",$P(@(DIU_"0)"),U,2)=DIU(0)
 ;I 'Y,DIU(0)["a" S DIU(0)=$P(DIU(0),"a")_$P(DIU(0),"a",2),$P(@(DIU_"0)"),U,2)=DIU(0)
 ;
DDA K DIR S DIR("A")="DD AUDIT",DIR(0)="YO"
 S:$D(^DD(DA,0,"DDA")) DIR("B")=$S(^("DDA")["Y":"YES",1:"NO")
 S DIR("??")="^W !!?5,""Enter 'Y' (YES) if you want to audit the Data Dictionary changes"",!?5,""for this file."""
 D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)  S ^DD(DA,0,"DDA")=$S(Y=1:"Y",1:"N")
DIE ;D DIE^DIU21 Q:$D(DTOUT)!$D(DUOUT)
 ;
OK S %=DIU(0)'["O"+1
 W !,"ASK 'OK' WHEN LOOKING UP AN ENTRY" D YN^DICN
 I %>0 S $P(@(DIU_"0)"),U,2)=$P(DIU(0),"O")_$E("O",%)_$P(DIU(0),"O",2)
 I '% W !?5,"Answer YES to cause a lookup into this file to verify the",!?5,"selection by prompting with '...OK? YES//'." G OK
 I DUZ(0)="@",%'<0 D ^DIU21
Q K DIR,DIRUT,DTOUT,DUOUT,DIROUT Q
 ;
K ; CALLED BY ^DD(1,.01,"DEL",1,0)
 S %=2,DG=@(DIU_"0)")
 I $P($G(^DD(+$P(DG,U,2),0,"DI")),U,2)["Y" W $C(7)," CANNOT DELETE A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!" Q
 I $P(DG,U,4)>1 W $C(7),!,"DO YOU WANT JUST TO DELETE THE ",$P(DG,U,4)," FILE ENTRIES,",!?9,"& KEEP THE FILE DEFINITION" D YN^DICN I %=1 G KL
 Q
KL K % S %=$L(DIU),%=$E(DIU,1,%-1)_$E(")",$E(DIU,%)=","),%Y="%(",%X=DIU_"0," D %XY^%RCR K @% S @(DIU_"0)")=$P(DG,U,1,2)_U,^DIC(DA,0,"GL")=DIU,%X="%(",%Y=DIU_"0," D %XY^%RCR K % I 1 Q
 ;
RW W !,$P("DATA DICTIONARY^READ^WRITE^DELETE^LAYGO^AUDIT",U,DR)," ACCESS: " G R:Y="" W Y I DUZ(0)'="@" F X=1:1:$L(Y) Q:DUZ(0)[$E(Y,X)  G Q:X=$L(Y)
 W "// "
R R X:DTIME S:'$T X=U,DTOUT=1 Q:X=""
 I X["@" G V:Y="" W $C(7),"   PROTECTION ERASED!" K ^(D) Q
 Q:X[U
 I X["?" W !,"ENTER CODE(S) TO RESTRICT USER'S ACCESS TO THIS FILE" G RW
V I DUZ(0)'="@" F Z=1:1:$L(X) I DUZ(0)'[$E(X,Z) W $C(7),"??" G RW
 S ^(D)=X Q
EN ;
 Q:'$D(DIU)  G EN^DIU0

DIU21
DIU21 ;SFISC/XAK-EDIT FILE (PGMR PART) ;12/20/93  10:28
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D:'$D(DISYS) OS^DII Q:$G(^DD("OS",DISYS,18))=""
ACT K DIR S DIR(0)="FOU^3:250",DIR("A")=$$EZBLD^DIALOG(8013) S:$D(^DD(DA,0,"ACT")) DIR("B")=^("ACT")
 S DIR("?",1)=$$EZBLD^DIALOG(9025),DIR("?")=$$EZBLD^DIALOG(9024)
 D ^DIR G:$D(DTOUT)!($D(DUOUT)) Q K DIRUT,DIROUT G:X="" DIC
 I "@"'[X D ^DIM I $D(X) S ^DD(DA,0,"ACT")=X G DIC
 I $G(X)="@" K ^DD(DA,0,"ACT") W "   "_$$EZBLD^DIALOG(8015) G DIC
 W $C(7),"   ",$$EZBLD^DIALOG(9025) G ACT
DIC K DIR N Y,DIPARAM S DIR(0)="FO^3:8^K:X?1""DI"".E X",DIR("A")=$$EZBLD^DIALOG(8014) S:$G(^DD(DA,0,"DIC"))]"" DIR("B")=^("DIC")
 S DIPARAM=9026,DIPARAM(1)=8 D H,H1
 D ^DIR K DIRUT,DIROUT
 G:$D(DTOUT)!($D(DUOUT)) Q G:X="" DIK
 I X="@" K ^DD(DA,0,"DIC") W "   "_$$EZBLD^DIALOG(8015) G DIK
 I '$$ROUEXIST^DILIBF(X) W $C(7),"   ",$$EZBLD^DIALOG(8017) G DIC
 S ^DD(DA,0,"DIC")=X
DIK S X=$G(^DD(DA,0,"DIKOLD")),Y=$G(^("DIK")) I X]"",X'=Y W !,"   " D BLD^DIALOG(8018,X,"","DIR") W DIR
 K DIR S DIR(0)="FO^3:6^K:X?1""DI"".E X",DIR("A")=$$EZBLD^DIALOG(8019) S:Y]"" DIR("B")=Y
 S DIPARAM=9027,DIPARAM(1)=6 D H,H1
 D ^DIR I X="@" G QA
 G:$D(DIRUT)!(X="") Q
 I $$ROUEXIST^DILIBF(X) W $C(7),! S DIPARAM(1)=X D BLD^DIALOG(8016,.DIPARAM,"","DIR") W DIR
 K DIR N DICMP S DICMP=0 I $G(^DD(DA,0,"DIK"))=""!($G(^("DIK"))'=X) S DICMP=1
 N DIKPGM S DIKPGM=X
 S DIR(0)="YO",DIR("A")=$$EZBLD^DIALOG(8020)
 I 'DICMP S DIR("B")="NO" D BLD^DIALOG(9028,"","","DIR(""?"")")
 I DICMP S DIR("B")="YES" D BLD^DIALOG(9029,"","","DIR(""?"")")
 D ^DIR G Q:$D(DIRUT)
 I 'Y G:'DICMP Q W $C(7) G QA
 S X=DIKPGM,Y=DA,DMAX=^DD("ROU") K DIR,DICMP,DIKPGM G EN^DIKZ
 ;
A N DA S DA=+X N X K ^DD(DA,0,"DIK")
 F X=0:0 S X=$O(^DD(DA,"SB",X)) Q:X'>0  D A
 Q
QA S X=DA D A W "   "_$$EZBLD^DIALOG(8015),!,"   ",$$EZBLD^DIALOG(8021)
Q Q
H ; Build help for entering routine name.
 D BLD^DIALOG(9006,.DIPARAM,"","DIR(""?"")") Q
H1 N I S I=$O(DIR("?",":"),-1) I I S DIR("?",I+1)=DIR("?")
 I DIPARAM=9027 S DIR("?",I+2)=$$EZBLD^DIALOG(9030)
 D BLD^DIALOG(DIPARAM,"","","DIR(""?"")") Q
 ;
DIE ;not in 20
 I $P($G(^DD(DA,0,"DI")),U)["Y" W !,$C(7),"RESTRICT EDITING OF FILE? YES//  (UNEDITABLE) THIS IS AN ARCHIVE FILE." Q
 N DIR,DIEYN S DIR(0)="YO",DIR("A")="RESTRICT EDITING OF FILE",DIR("B")=$S($P($G(^DD(DA,0,"DI")),U,2)["Y":"YES",1:"NO")
 S DIR("?",1)="YES will not allow editing or deleting existing file entries or adding new file     entries",DIR("?")="NO  will place no restrictions on the file"
 D ^DIR Q:$D(DTOUT)!$D(DUOUT)
 S DIEYN=$S(Y:"Y",1:"N")
 D DIE1 Q:$D(DTOUT)!($D(DUOUT))  G:'$D(DIEYN) DIE
 S $P(^DD(DA,0,"DI"),U,2)=DIEYN
 Q
DIE1 Q:Y&($E(DIR("B"))="Y")  Q:'Y&($E(DIR("B"))="N")
 I Y W !,$C(7),"WARNING- DATA IN THIS FILE IS NOW UNEDITABLE"
 I 'Y W !,$C(7),"WARNING- DATA IN THIS FILE IS NOW EDITABLE"
 K DIR S DIR(0)="Y",DIR("A")="ARE YOU SURE"
 D ^DIR Q:$D(DTOUT)!$D(DUOUT)  K:'Y DIEYN
 Q
 ;
 ;DIALOG #8013  'POST-SELECTION ACTION'
 ;       #8014  'LOOK-UP PROGRAM'
 ;       #8015  'Deleted.'
 ;       #8016  'Note that...is already in the routine directory.'
 ;       #8017  'This routine does not exist in the routine directory.'
 ;       #8018  'Previously compiled under routine name...'
 ;       #8019  'CROSS-REFERENCE ROUTINE'
 ;       #8020  'Should the compilation run now'
 ;       #8021  'The compiled routines will no longer be used...'
 ;       #9006  'Enter a valid MUMPS routine name of from 3 to...'
 ;       #9024  'This code will be executed whenever an entry is...'
 ;       #9025  'Enter a line of standard MUMPS code'
 ;       #9026  'This special lookup routine will be executed...'
 ;       #9027  'if a NEW routine name is entered, but the cross-ref...'
 ;       #9028  'It is not necessary to recompile the cross-ref...'
 ;       #9029  'If the cross-references are not recompiled...'
 ;       #9030  'This will become the namespace of the compiled routine'

DIU3
DIU3 ;SFISC/GFT-IDENTIFIERS ;2/24/93  14:16 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
3 ;
 S %=2,X="W """"",DA=+Y
 I $D(^DD(DI,0,"ID",+Y)) W !,"'",$P(Y,U,2),"' is already and Identifier; Want to delete it" D YN^DICN Q:%'=1  K ^DD(DI,0,"ID",+Y) D:$D(DDA) A Q
 W !,"Want to make '",$P(Y,U,2),"' an Identifier" D YN^DICN Q:%-1
 S %=$O(^DD(DI,0,"NM",0))
 W !,"Want to display "_$P(Y,U,2)_" whenever a lookup is done",!,"  on an entry in the '"_%_"' File" S %=1 D YN^DICN
 I %-1 G S:%=2&(Y-.001) W $C(7),"??" Q
 S V=$P(Y(0),U,2),X=$P(Y(0),U,4),D="W",%="(^(0)",%Y=$P(X,";")
 I %Y'=0 S D=$S(+%Y=%Y:"",V["S":"""""",1:""""),%="(^("_D_%Y_D_")",D="W"_$S(+Y'=.001:":$D(^("_$E(D)_%Y_$E(D)_"))",1:"")
 S %Y=$P(X,";",2),X=$S(+Y=.001:"Y",%Y:"$P"_%_",U,"_%Y_")",1:"$E"_%_","_+$E(%Y,2,9)_","_$P(%Y,",",2)_")")
 I V["D" S X="$E("_X_",4,5)_""-""_$E("_X_",6,7)_""-""_$E("_X_",2,3)"
 I V["P" S X="S %I=Y,Y=$S('$D"_%_"):"""",$D(^"_$P(Y(0),U,3)_"+"_X_",0))#2:$P(^(0),U,1),1:""""),C=$P(^DD("_+$P(V,"P",2)_",.01,0),U,2) D Y^DIQ:Y]"""" W ""   "",Y,@(""$E(""_DIC_""%I,0),0)"") S Y=%I K %I" G S
 I V["V" S X=$P(Y(0),U,4),X="S DIY=$S($D(@(DIC_(+Y)_"","""""_$P(X,";",1)_""""")"")):$P(^("""_$P(X,";",1)_"""),U,"_$P(X,";",2)_"),1:"""") D NAME^DICM2 W ""   "",DINAME,@(""$E(""_DIC_""Y,0),0)"")" G S
 I V["S" S X="@(""$P($P($C(59)_$S($D(^DD("_DI_","_+Y_",0)):$P(^(0),U,3),1:0)_$E(""_DIC_""Y,0),0),$C(59)_"_X_"_"""":"""",2),$C(59),1)"")"
 S X=D_" ""   "","_X
S S ^DD(DI,0,"ID",+Y)=X,X=DIU I $D(DDA) S A0="IDENTIFIER^",A1="",A2="ID" D IT^DICATTA
 I N S V=N,P=$O(^DD(J(N-1),"SB",DI,0)) S:P="" P=-1 S X="^DD(J(N-1),P,"
 S @("X="_X_"0)"),%=$P(X,U,2) I %'["I" S ^(0)=$P(X,U)_U_%_"I"_U_$P(X,U,3,99)
 I N S DIFLD=+Y D WAIT^DICD,0^DIVR S:DE?.E1"  " DE=$E(DE,1,$L(DE)-2) X DE K DE,DA,X,W,DIFLD
 Q
 ;
A S A0="IDENTIFIER^",A1="ID",A2="" D IT^DICATTA K A0,A1,A2 Q
 ;

DIU31
DIU31 ;SFISC/GFT-UNEDITABLE, INPUT TRANS., OUTPUT TRANS. ;10/4/90  8:57 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
9 ;
 S %=2,DA=+Y
 I $P(Y(0),U,2)["I" W !,$C(7),"FIELD IS ALREADY UNEDITABLE",!,"DO YOU WANT TO ALLOW EDITING AGAIN" D YN^DICN Q:%-1  S X=$P(^(0),U,2),^(0)=$P(^(0),U,1)_U_$P(X,"I",1)_$P(X,"I",2)_$P(X,"I",3)_U_$P(^(0),U,3,99) W "  ..OK" S %=1 G 2
 W !,"WANT TO PREVENT ALL USERS FROM CHANGING OR DELETING DATA VALUES",!
 W "THAT ARE ENTERED FOR THE '"_$P(Y,U,2)_"' FIELD" D YN^DICN Q:%-1  S ^(0)=$P(^(0),U,1,2)_"I^"_$P(^(0),U,3,99) W $C(7),!?9,"...FIELD IS NOW UNEDITABLE!" S %=2
2 I $D(DDA) S A0="UNEDITABLE^",(A1,A2)="",@("A"_%)="I" D IT^DICATTA
 G DIEZ^DIU0
 ;
5 W !,$P(Y,U,2) S DA=+Y,Y=$P(Y(0),U,5,99) S:$D(DDA) DDA=Y
 W " INPUT TRANSFORM: ",Y D RW^DIR2 Q:X=""  S %=$L($P(Y(0),U,1,4))+$L(X) I %>244 W !!?5,$C(7),"Input Transform is TOO LONG by ",%-244," characters.",! K X S Y=DA_U_$P(Y(0),U) G 5
 I $P(Y(0),U,2)["K",X'[" ^DIM" K X S Y=DA_U_$P(Y(0),U) W $C(7),!?5,"Input Transform must contain D ^DIM",! G 5
 I $P(Y(0),U,2)["F",X["DINUM" W $C(7),!?5,"DINUM on a Freetext field can cause database",!?5,"problems unless you are sure DINUM is numeric."
 D ^DIM I '$D(X) W $C(7),"??" S Y=DA_U_$P(Y(0),U) G 5
 S ^DD(DI,DA,0)=$P(Y(0),U,1,2)_$E("X",$P(Y(0),U,2)'["X")_U_$P(Y(0),U,3,4)_U_X
 I $D(DDA),DDA'=X S A0="INPUT TRANSFORM^.5",A1=DDA,A2=X D IT^DICATTA
 S DR="3:4" I $P(Y(0),U,2)["P" S %=$F(X," D ^DIC") I % S X=$E(X,1,%-8),%=$F(X,"DIC(""S"")=") I % S X=$E(X,%-9,$L(X)),^(12.1)="S "_X,DR=DR_";12EXPLANATION OF SCREEN"
 S DIE=DIC I $P(Y(0),U,2)["C" D PZ^DIU0 G Q
 F %=3,4,12.1 S:$D(^DD(DI,DA,%)) ^UTILITY("DDA",$J,DI,DA,%)=^(%)
 S DDA=DI D ^DIE S DI=DDA D IT1^DICATTA,DIEZ^DIU0 G Q
 ;
O S DIK=1,DJJ=+Y W !,$P(Y,U,2)_" OUTPUT TRANSFORM: "
 I '$D(^DD(DI,DJJ,2)) R X:DTIME I '$T S DTOUT=1 G Q
 I $D(^(2)) S (DIK,Y)=^(2) S:$D(DDA) DDA=Y S:$D(^(2.1)) Y=^(2.1) W Y D RW^DIR2 I X="@" W !?9,"DELETED!" K ^(2),^(2.1) S Y=$P(^(0),U,2),$P(^(0),U,2)=$P(Y,"O")_$P(Y,"O",2),%="" G EX
 G Q:X="" I X?."?" S Y=DJJ_U_$P(^(0),U) W !?4,"Enter a computed-field expression using '"_$P(Y,U,2)_"'",! W:DUZ(0)="@" ?4,"or MUMPS code that takes Y and transforms it to a different Y.",! G O
 K ^(2) S DICOMPX(1,DI,DJJ)="Y(0)",DA=DIC_DJJ_",2,",DGG=X,DQI="Y("
 D ^DICOMP K DQI,DICOMPX F %=9.2:.1 Q:'$D(X(%))  S @(DA_"%)=X(%)")
 I $D(X) S ^DD(DI,DJJ,2)="S Y(0)=Y "_X_$P(" S Y=X",U,Y'["X"),^(2.1)=DGG S:$P(^(0),U,2)'["O" $P(^(0),U,2)=$P(^(0),U,2)_"O" S %=^(2) G EX
 S:'DIK ^DD(DI,DJJ,2)=DIK
X W $C(7),"??" Q
 ;
EX S DA=DJJ I $D(DDA),DDA'=% S A1=DDA,A2=%,A0="OUTPUT TRANSFORM^2" D IT^DICATTA
 D PZ^DIU0
Q G Q^DIU

DIU4
DIU4 ;SFISC/XAK-SPECIFIER ;6/11/93  2:29 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W ! S DIU=Y K DIR G S:'$D(^DD(DI,0,"SP",+Y))
 S DIR("A",1)=$P(DIU,U,2)_" is already a specifier."
 S DIR("A")="Do you want to delete it"
 S DIR("??")="^W !!?5,""Deleting a specifier means that this field will not be used"",!?5,""in trying to match entries going from one system to another."""
 S DIR("B")="NO",DIR(0)="Y" D ^DIR G Q:$D(DTOUT)!$D(DUOUT),E:'Y
 K:Y ^DD(DI,0,"SP",+DIU) G Q
S S DIR("A")="Want to make "_$P(Y,U,2)_" a specifier"
 S DIR("??")="^W !!?5,""Making this field a specifier means that it will be used in"",!?5,""finding a specific entry when it is sent from one system to another."""
 S DIR("B")="NO",DIR(0)="Y" D ^DIR G Q:$D(DIRUT)!'Y
E K DIR("A") S DIR("A")="Is the value of this field unique for each entry"
 S DIR("??")="^W !!?5,""If this field is unique, then each entry in the file"",!?5,""has a different "_$P(DIU,U,2)_"."""
 D ^DIR G Q:$D(DIRUT) S:Y!('Y&(+DIU'=.01)) ^DD(DI,0,"SP",+DIU)=$S(Y:Y,1:"") G Q:'Y
 K DIR S DIR(0)="SO^"
 F %=0:0 S %=$O(^DD(DI,+DIU,1,%)) Q:+%'=%  I $D(^(%,0)),+^(0) S DIR(0)=DIR(0)_%_":"_$P(^(0),U,2)_"  "_$S($P(^(0),U,3)]"":$P(^(0),U,3),1:"REGULAR")_";"
 I $P(DIR(0),U,2)="" K:+DIU=.01 ^DD(DI,0,"SP",+DIU) G Q
 S DIR("?")="Enter one of the cross-references in the list, or press return."
 S DIR("A",1)="If one of the above provides a direct lookup by "_$P(DIU,U,2)_","
 S DIR("A")="please enter its number or name"
 D ^DIR I '$D(DTOUT),'$D(DUOUT) S ^DD(DI,0,"SP",+DIU)="1^"_$S(Y:$P(Y(0)," "),1:"")
 I $D(DIRUT),(+DIU=.01) K ^DD(DI,0,"SP",+DIU)
Q K DUOUT,DTOUT,C,DIR,DIRUT,DIROUT
 Q

DIU5
DIU5 ;SFISC/TKW-QUERY CONDITION EXTRINSIC FUNCTIONS ;8/27/93  13:41
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
BEF(X,Y,N) ; X BEFORE Y
 I $G(N)="'" G:Y']]X Q1 Q 0
 G:Y]]X Q1 Q 0
Q1 Q 1
AFT(X,Y,N) ; X AFTER Y
 I $G(N)="'" G:X']]Y Q1 Q 0
 G:X]]Y Q1 Q 0
BTWI(X,Y,Z,N) ;X BETWEEN INCLUSIVE Y & Z
 I $G(N)="'" G:Y]]X Q1 G:X]]Z Q1 Q 0
 G:(Y']]X)&(X']]Z) Q1 Q 0
BTWE(X,Y,Z,N) ;X BETWEEN EXCLUSIVE Y & Z
 I $G(N)="'" G:X']]Y Q1 G:Z']]X Q1 Q 0
 G:(X]]Y)&(Z]]X) Q1 Q 0
EQ(X,Y,N) ;X EQUALS Y
 I $G(N)="'" G:X'=Y Q1 Q 0
 G:X=Y Q1 Q 0
NULL(X,N) ;X IS NULL
 I $G(N)="'" G:X'="" Q1 Q 0
 G:X="" Q1 Q 0

DIV
DIV ;SFISC/GFT-VERIFY FLDS ;8/22/95  07:14
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N DIUTIL S DIUTIL="VERIFY FIELDS"
 K J
 S Q="""",S=";",V=0,P=0,I(0)=DIU,@("(A,J(0))=+$P("_DIU_"0),U,2)")
 I $O(^(0))'>0 W $C(7),"  NO ENTRIES ON FILE!" Q
DIC S DIC="^DD(A,",DIC(0)="EZ",DIC("W")="W:$P(^(0),U,2) ""  (multiple)"""
 S DIC("S")="S %=$P(^(0),U,2) I %'[""C"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W"")"
 W !,"VERIFY WHICH "_$P(^DD(A,0),U)_": " R X:DTIME Q:U[X
 I X="ALL" D ALL G Q:$D(DIRUT) I Y D FLDS G Q^DIVR:DQI'>0
 D ^DIC K DQI,^UTILITY("DIVR",$J)
 I Y<0 W:X?1."?" !?3,"You may enter ALL to verify every field at this level of the file.",! G DIC
 S DR=$P(Y(0),U,2) I DR S J(V)=A,P=+Y,V=V+1,A=+DR,I(V)=$P($P(Y(0),U,4),S,1) S:+I(V)'=I(V) I(V)=Q_I(V)_Q G DIC
1 F T="N","D","P","S","V","F" Q:DR[T
 F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K" I T[$E(W) S:W="K" W="MUMPS" W "   ",W Q
 K DA S DIVZ=$P(Y(0),U,3),DDC=$P(Y(0),U,5,99),(DIFLD,DA)=+Y
 G ^DIVR
 ;
Q K DIR,DIRUT,N,P,Q,S,V,C
 Q
 ;
ALL S DIR(0)="Y",DIR("??")="^D H^DIV"
 S DIR("A")="DO YOU MEAN ALL THE FIELDS IN THE FILE"
 D ^DIR K DIR S X="ALL"
 Q
 ;
FLDS S DQI=0 F  S DQI=$O(^DD(A,DQI)) Q:DQI'>0  S Y=DQI,Y(0)=^(Y,0),DR=$P(Y(0),U,2) D
 .I DR,$P(^DD(+DR,.01,0),U,2)["W" Q
 .I DR D NEXTLVL Q
 .I DR'["C" W !!!,"--",$P(Y(0),U),"--" D 1 Q
 Q
NEXTLVL ;
 N A,P,DE,DA,DQI,I,J,V S DQI=0
 S A=+DR,P=+Y N Y,DR D IJ^DIVU(A)
 D FLDS
 Q
H W !!?5,"YES means that every field at this level in the file will"
 W !?5,"be checked to see if it conforms to the input transform."
 W !!?5,"NO means that ALL will be used to lookup a field in the"
 W !?5,"file which begins with the letters ALL, e.g., ALLERGIES."
 Q
VER(DIVRFILE,DIVRREC,DIVRDR,DIVROUT) ;
 ;DIVRFILE = (sub)file number
 ;DIVRREC = template, or ien-string of records to be verified
 ;DIVRDR = list of fields to be verified (defaults to ALL)
 ;DIVROUT = output array listing the records that had problems
 G ^DIVR1
DIVROUT I $G(DIVROUT)="" D X Q
 I $E(DIVROUT)="[" D  Q
 . N Y,COUNT,Z
 . D DIBT^DIVU(DIVROUT,.Y,DIVRFI0) Q:Y'>0
 . K ^DIBT(+Y,1)
 . S (COUNT,Z)=0
 . F  S Z=$O(^TMP("DIVR1",$J,Z)) Q:Z=""  S COUNT=COUNT+1,^DIBT(+Y,1,Z)=""
 . I COUNT S ^DIBT(+Y,"QR")=DT_U_COUNT
 . D X
 M @DIVROUT@(1)=^TMP("DIVR1",$J)
X K ^TMP("DIVR1",$J)
 Q

DIVR
DIVR ;SFISC/GFT-VERIFY FLDS ;11:00 AM  19 Mar 1996
 ;;21.0;VA FileMan;**8**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S W="W !,""ENTRY#"_$S(V:"'S",1:"")_""",?10,"""_$P(^DD(A,.01,0),U)_""",?40,""ERROR"""
 W ! S T=$E(T) S:"PS"[T&($D(DIVZ)[0) DIVZ=Z G E:'$D(^(+$O(^DD(A,DA,1,0)),1)) K DG
 F %=0:0 S %=$O(^DD(A,DA,1,%)) Q:%'>0  I $D(^(%,1)),$P(^(0),U,2,9)?1.A,^(2)?1"K ^".E1")",^(1)?1"S ^".E S DG(%)="I $D("_$E(^(2),3,99)_"),"_$E(^(1),3,99)
 I $D(DG) W "(CHECKING" S E=T,T="IX"
 E  W $C(7),"(CANNOT CHECK"
 W " CROSS-REFERENCE)",!
E S Y=$F(DDC,"%DT=""E") S:Y DDC=$E(DDC,1,Y-2)_$E(DDC,Y,999)
 I DR["*" S DDC="Q" I $D(^DD(A,DA,12.1)) X ^(12.1) I $D(DIC("S")) S DDC(1)=DIC("S"),DDC="X DDC(1) E  K X"
 D 0 S X=$P(Y(0),U,4),Y=$P(X,S,2),X=$P(X,S)
 I +X'=X S X=Q_X_Q I Y="" S DE=DE_"S X=DA D R" G XEC
 S M="S X=$S($D(^(DA,"_X_")):$"_$S(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$E(Y,2,9))_"),1:"""") D R"
 I $L(M)+$L(DE)>250 S DE=DE_"X DE(1)",DE(1)=M
 E  S DE=DE_M
XEC K DIC,M,Y X DE Q:$D(DQI)
 W:'$D(M) $C(7),!,"NO PROBLEMS"
Q S M=$O(^UTILITY("DIVR",$J,0)),E=$O(^(M)),DK=J(0)
 G:'E QX K DIBT,DISV D
 . N C,D,I,J,L,O,Q,S,D0,DDA,DICL,DIFLD,DIU0
 . D S2^DIBT1 Q
 S DDC=0 I '$D(DIRUT) G Q:Y<0 F E=0:0 S E=$O(^UTILITY("DIVR",$J,E)) Q:E=""  S DDC=DDC+1,^DIBT(+Y,1,E)=""
 S:DDC>0 ^DIBT(+Y,"QR")=DT_U_DDC
QX K ^UTILITY("DIVR",$J),DIRUT,DIROUT,DTOUT,DUOUT,DQI,DK,DA,DG,DQ,DE,T,P,E,M,DR,W,DDC,DIVZ Q
 ;
R I X?." " Q:DR'["R"  S M="Missing" G X
 G @T
 ;
P I @("$D(^"_DIVZ_"X,0))") S Y=X G F
 S M="No '"_X_"' in pointed-to File" G X
 ;
S S Y=X X DDC I '$D(X) S M=Q_Y_Q_" fails screen" G X
 Q:S_DIVZ[(S_X_":")  S M=Q_X_Q_" not in Set" G X
 ;
D S Y=X,X=$E(Y,1,3)+1700,%=$E(Y,6,7) S:% X=%_"-"_X S:$E(Y,4,5) X=+$E(Y,4,5)_"-"_X
 S:Y["." X=X_"@"_$E(Y_"00",9,10)_":"_$E(Y_"0000",11,12)_$S($E(Y,13,14):":"_$E(Y_"0",13,14),1:"")
N ;
K ;
F S DQ=X I X'?.ANP S M="Non-printing character" G X
 X DDC Q:$D(X)  S M=Q_DQ_Q_" fails Input Transform"
X I $O(^UTILITY("DIVR",$J,0))="" X W
 S X=$S(V:DA(V),1:DA),^UTILITY("DIVR",$J,X)=""
 S X=V I @(I(0)_"0)")
DA I 'X W !,DA,?10,$S($D(^(DA,0)):$P(^(0),U),1:DA),?40,$E(M,1,40) W:V ! Q
 W !,DA(X),?10,$P(^(DA(X),0),U) S X=X-1,@("Y=$D(^("_I(V-X)_",0))") G DA
 ;
0 ;
 S Y=I(0),DE="",X=V
L S DA="DA" S:X DA=DA_"("_X_")" S Y=Y_DA,DE=DE_"F "_DA_"=0:0 ",%="S "_DA_"=$O("_Y_"))" I V>2 S DE(X+X)=%,DE=DE_"X DE("_(X+X)_")"
 E  S DE=DE_%
 S DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "
 I X=1,DIFLD=.01 S DE=DE_"X P:$D(^(DA(1),"_I(V)_",0)) ",P="S $P(^(0),U,2)="""_$P(^DD(J(V-1),P,0),U,2)_Q
 S X=X-1 Q:X<0  S Y=Y_","_I(V-X)_"," G L
 ;
IX F %=0:0 S %=$O(DG(%)) Q:+%'>0  X DG(%) I '$T S M=Q_X_Q_" not properly Cross-referenced" G X
 G @E
 ;
V I $P(X,S,2)'?1A.AN1"(".ANP,$P(X,S,2)'?1"%".AN1"(".ANP S M=Q_X_Q_" has the wrong format" G X
 S M=$S($D(@(U_$P(X,S,2)_"0)")):^(0),1:"")
 I '$D(^DD(A,DIFLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" G X
 I '$D(@(U_$P(X,S,2)_+X_",0)")) S M=U_$P(X,S,2)_+X_",0) does not exist" G X
 G F

DIVR1
DIVR1 ;SFISC/DCM-VERIFY FIELDS API ;8/16/96  16:43
 ;;21.0;VA FileMan;**8**;Aug 22, 1995
 ;Per VHA Directive 10-93-142, this routine should not be modified
EN ;
 I '$D(DIVRREC) S DIVRREC=""
 N %ZIS,POP,ZTRTN,ZTSAVE,SUB
 S %ZIS="Q" D ^%ZIS  Q:POP
 I $D(IO("Q")) S ZTRTN="DQ^DIVR1",(ZTSAVE("DIVRFILE"),ZTSAVE("DIVRDR"),ZTSAVE("DIVROUT"))="" S SUB="DIVRREC"_$S($D(DIVRREC)=10:"(",1:"") S ZTSAVE(SUB)="" D ^%ZTLOAD Q
DQ N PG,TAB,REC,Y,DATE,I,J,K,DIVRFI0,DIVRFINM,DIVRFIIN,DA,V,DIRUT,R,DE,DIUTIL
 K ^TMP("DIVR1",$J),^TMP("DIERR",$J)
 I $D(ZTQUEUED) S ZTREQ="@"
 S PG=0,TAB=0,REC=0,DIUTIL="VERIFY FIELDS" U IO
 S Y=DT D DD^%DT S DATE=Y
 D DIVRFILE Q:$G(DIERR)
 D DIVRREC
 I '$D(^TMP("DIVR1",$J)),'$G(DIERR) W !!!,?20,"*** NO ERRORS FOUND ***" D Q
 D DIVROUT^DIV,Q
 Q
DIVRFILE S (DIVRFILE,DIVRFIIN)=+DIVRFILE
 Q:'$$VFILE^DILFD(DIVRFILE,"D")
 S DIVRFI0=$$FNO^DILIBF(DIVRFILE),DIVRFINM=$$GET1^DID(DIVRFI0,"","","NAME")
 Q
DIVRREC S R=$D(DIVRREC)
 I $D(DIVRREC)#2,(DIVRREC=""!(DIVRREC="ALL")) S R=0 D IJ^DIVU(DIVRFIIN),H1,DIVRDR Q
 I $D(DIVRREC)#2,$E(DIVRREC)="[" D  Q
 . N Y,D0,DS D DIBT^DIVU(DIVRREC,.Y,DIVRFI0) Q:Y'>0
 . S D0=0 D H2,IJ^DIVU(DIVRFI0) F  S D0=$O(^DIBT(+Y,1,D0)) Q:D0'>0  S DE="",DS=1 D:$$VENTRY^DIEFU(DIVRFI0,+D0,"D") DIVRDR Q:$D(DIRUT)
 I $D(DIVRREC)=10 D  Q
 . N I S I="" D H2,IJ^DIVU(DIVRFIIN)
 . F  S I=$O(DIVRREC(I)) Q:I'>0  S DIVRREC=I D ONE
 D H2,IJ^DIVU(DIVRFIIN)
ONE Q:'$$IENCHK^DIT3(DIVRFIIN,DIVRREC)
 Q:'$$VENTRY^DIEFU(DIVRFIIN,DIVRREC,"D")
 N %,DEPTH,D,DS
 S DEPTH=$L(DIVRREC,",")-1
 F %=1:1:DEPTH S D="D"_(DEPTH-%) N @D S @D=$P(DIVRREC,",",%)
 S DS=DEPTH D DIVRDR
 Q
DIVRDR N FLD,PC,Z,END,OUT,F,Y,Q,S
 S F=1,FLD=0,Q="""",S=";"
 S:$G(DIVRDR)="" DIVRDR="ALL"
 I DIVRDR="ALL" D  Q
 . F  S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0  D SET Q:$D(DIRUT)
 F  S Z=$G(Z)+1 S PC=$P(DIVRDR,S,Z) Q:PC=""  D  Q:$D(DIRUT)
 . N Z
 . I PC[":" S FLD=$O(^DD(DIVRFILE,+PC),-1),END=+$P(PC,":",2) D  Q
 . . F  S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0!(FLD>END)  D SET Q:$D(DIRUT)
 . S FLD=PC I $$VFIELD^DILFD(DIVRFILE,PC,"D") D SET  Q
 Q
SET N TYP,IT,T,W,PC3,M,Y
 S Y=FLD,Y(0)=^DD(DIVRFILE,FLD,0),TYP=$P(Y(0),U,2),IT=$P(Y(0),U,5,99),PC3=$P(Y(0),U,3)
 F T="N","D","P","S","V","F" Q:TYP[T
 F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K" I T[$E(W) S:W="K" W="MUMPS" Q
 I TYP["C" Q
 I TYP,$P(^DD(+TYP,.01,0),U,2)["W" Q
 I TYP D MULT Q
 I 'R D:$Y>(IOSL-4) FF Q:$D(DIRUT)  W !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_" (#"_FLD_")",?40,W
 I TYP["*",TYP'["X" S IT="Q" I $D(^DD(DIVRFILE,FLD,12.1)) X ^(12.1) I $D(DIC("S")) S IT(1)=DIC("S"),IT="X IT(1) E  K X"
 D XDE
 Q
XDE I F D
 .I R,DIVRFILE=DIVRFIIN S DE="D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
 .D DE^DIVU(DIVRFILE,"","","DE",$G(DS)_U_$G(DS)) S F=0,DE=DE_" D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
 D DE99(DIVRFILE,FLD)
 X DE
 Q
MULT D:$Y>(IOSL-4) FF Q:$D(DIRUT)
 W:'R !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_"(#"_FLD_") --multiple--"
 N DIVRFILE,FLD,DA,V,I,J,K,F,DE
 S DIVRFILE=+TYP,FLD=0,TAB=TAB+2,F=1 D IJ^DIVU(DIVRFILE)
 F  S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0  D SET Q:$D(DIRUT)
 S TAB=TAB-2 K @("D"_V)
 Q
R I X?." " Q:TYP'["R"  S M="Missing" D X Q
 D @T Q
P I @("$D(^"_PC3_"X,0))") D F Q
 S M="No '"_X_"' in pointed-to File" D X Q
V I $P(X,S,2)'?1A.AN1"(".ANP,$P(X,S,2)'?1"%".AN1"(".ANP S M=Q_X_Q_" has the wrong format" D X Q
 S M=$S($D(@(U_$P(X,S,2)_"0)")):^(0),1:"")
 I '$D(^DD(DIVRFILE,FLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" D X Q
 I '$D(@(U_$P(X,S,2)_+X_",0)")) S M=U_$P(X,S,2)_+X_",0) does not exist" D X Q
 D F Q
S S Y=X I TYP'["X" X IT I '$D(X) S M=Q_Y_Q_" fails screen" D X Q
 Q:S_PC3[(S_X_":")  S M=Q_X_Q_" not in Set" D X Q
D N Y,%DT S Y=$F(IT,"%DT=""E") S:Y IT=$E(IT,1,Y-2)_$E(IT,Y,999)
 I TYP["X" X $P(IT," D ^%DT") D ^%DT I Y<0 S M="Invalid date" D X Q
 D F Q
N I TYP["X",X'?.1"-".N.".".N S M="Invalid number" D X Q
 D F Q
K D ^DIM I '$D(X) S M="Invalid M code" D X
 Q
F N Y S Y=X I X'?.ANP S M="Non-printing character" D X
IT Q:TYP["X"  D  Q:$D(X)  S M=Q_Y_Q_" fails Input Transform"
 .N %Y S %Y=Y X IT S Y=%Y
 ;
X S X=$S(V:DA(V),1:DA),^TMP("DIVR1",$J,$S('R:X,$G(DIVRREC)["[":X,(R&($G(DIVROUT)["[")):X,1:DIVRREC))="",X=V,Z=0
 I @(I(0)_"0)")
IEN D FF:$Y>(IOSL-3) Q:$D(DIRUT)
 I 'R D  Q
 .F  Q:'X  W !?5,@("D"_Z),?15,$P(^(@("D"_Z),0),U) S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
 .W !?5,@("D"_Z),?15,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)),?50,$E(M,1,40) W:V !
 I R D  Q
 .F  Q:'X  W !,@("D"_Z),?10,$P(^(@("D"_Z),0),U) W:Z " (",K(Z),")" S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
 .W !,@("D"_Z),?10,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)) W:Z " (",K(Z),")" W !?5,$P(^DD(DIVRFILE,FLD,0),U)," (#",FLD,")",?35,W,?50,M W:V !
 Q
 ;
DE99(FI,FD,NP) ;
 N Y
 D GET^DIOU(FI,FD,"X",.Y,"I")
 S DE(99)=Y_" D R " Q
 Q
Q D ^%ZISC
 Q
FF I IOST["C-" N DIR,X,Y S DIR(0)="E" D ^DIR Q:$D(DIRUT)
 I R D H2 Q
H1 W:$Y @IOF W "Verify Fields     File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
 W !,"Field Name (Field #)",?40,"Type"
 W !?5,"Entry #",?15,"Name",?50,"ERROR"
 N L W ! F L=1:1:(IOM-2) W "-"
 S PG=PG+1
 Q
H2 W:$Y @IOF W "Verify Fields     File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
 W !,"Entry #",?10,"Name"
 W !?5,"Field Name (Field #)",?35,"Type",?50,"ERROR"
 N L W ! F L=1:1:(IOM-2) W "-"
 S PG=PG+1
 Q

DIVRE
DIVRE ;SFISC/MWE-REQ FLD(S) CHK ;1/18/94  14:52
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
B K ^UTILITY($J),DIBT S (DK,DIC)=DI,DIC(0)="EQM",DIK=0
 W !,"CHECK WHICH ENTRY: " R X:DTIME G QQ:U[X!'$T
 I X="ALL" D ALL G QQ:$D(DIRUT) I Y S DIROOT=DIU G D
 D ^DIC I Y<0 W:X?1."?" !?3,"You may type 'ALL' to select every entry in the file.",! G B
R S DIK=DIK+1,^UTILITY($J,"DIN",+Y)=""
 S DIC(0)="AEQM",DIC("A")="ANOTHER ONE: " D ^DIC I Y>0 G R
 Q:'DIK!(X=U)
D ;
 D S2^DIBT1 K DIRUT,DIROUT G QQ:$D(DTOUT)!($D(DUOUT))
 I X]"" G D:Y<0 S:Y>0 DIBT=+Y
 S DIC=DI
 S:$D(^%ZTSK) %ZIS="Q" D ^%ZIS G:POP QQ
 I $G(IO("Q"))=1 G TSK
L I $E(IOST)="C" S DIFF=1
 S (DC,DA,N)=0 S:'$D(DIROOT) DIROOT="^UTILITY($J,""DIN""," F I=0:0 S DA=$O(@(DIROOT_DA_")")) Q:'DA  W:IOST?1"C".E "." D START
 I N U IO S DC=0 D PH F N=1:1 Q:'$D(^UTILITY($J,"DIVRE",N))  S X=^(N) D P I IOST?1"C".E,$Y>(IOSL-4) W $C(7) R X:DTIME Q:X=U!'$T
 I 'N U IO D PH W !!,"NO REQUIRED FIELD IS MISSING"
Q W:$E(IOST)'="C"&($Y) @IOF X $G(^%ZIS("C"))
QQ K DIRUT,DTOUT,DUOUT,DIROUT,DK,C,D,I,J,N,F,S,G,P,L,X,Y,DI,DIK,DIC,DISD,DIREF,DIFLD,DC,DIROOT,DIFF,^UTILITY($J)
 Q
P ;
 D:$Y>(IOSL-3) PH
 S %=$P(X,U),Y=$P(@(^DIC($P(%,";",2),0,"GL")_+%_",0)"),U,1),C=$P(^DD($P(%,";",2),.01,0),U,2) D Y^DIQ
 W !,+$P(X,U),?10,$E(Y,1,20),?35,$P(X,U,2),?50,$P(^DD($P(X,U,2),$P(X,U,3),0),U)
 Q:DUZ(0)'="@"
 I IOM>80 W ?85,$P(X,U,4) Q
 W !?35,$P(X,U,4) Q
PH ;
 S DC=DC+1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "Required-Field-Check  File: ",DIC_" "_$O(^DD(DIC,0,"NM","")),?(IOM-25) S Y=DT D DD^%DT W ?(IOM-10),"PAGE ",DC
 W !,"Entry",?35,"DD-Number",$S((DUZ(0)="@")+(IOM'>80)=2:"/Path",1:""),?50,"Field" I DUZ(0)="@",IOM>80 W ?85,"Path"
 W ! F L=1:1:(IOM-2) W "-"
 Q
CHECK ;
 Q:$P(^DD(DIC,DIFLD,0),U,2)'["R"
 S G=$P(^(0),U,4),P=$P(G,";",2),G=$P(G,";") S:'P P=1
 I $D(@(DIREF_","""_G_""")")),$P(^(G),U,P)]"" Q
 N % S %=0 S N=N+1,^UTILITY($J,"DIVRE",N)=D(1)_";"_I(1)_U_DIC_U_DIFLD_DIREF S:$D(DIBT) %=%+1,^DIBT(DIBT,1,D(1))=""
 I %,$G(DIBT) S ^DIBT(DIBT,"QR")=DT_U_%
 Q
START ;
 S L=1,DIC=$S('DIC:+$P(@(DIC_"0)"),U,2),1:DIC),DIREF=^DIC(DIC,0,"GL"),X="",U="^",DIREF=DIREF_DA
M S J(L)=DIREF,I(L)=DIC,D(L)=DA
 S DIFLD=0 F I=0:0 S DIFLD=$O(^DD(DIC,"RQ",DIFLD)),F(L)=DIFLD Q:'DIFLD  D CHECK
 S DISD=0 F I=0:0 S DISD=$O(^DD(DIC,"SB",DISD)) Q:'DISD  S S(L)=DISD D NEW
 Q
NEW ;
 S L=L+1
 S DIC=DISD,DIREF=DIREF_","_+$P(^DD(I(L-1),$O(^DD(I(L-1),"SB",DISD,"")),0),U,4)_","
 S DA=0 F I=0:0 S DA=$O(@(DIREF_DA_")")) Q:'DA  S DIREF(L)=DIREF,DIREF=DIREF_DA D M S DIREF=DIREF(L)
 S L=L-1,DIC=I(L),DIREF=J(L),DA=D(L),DIFLD=F(L),DISD=S(L)
 Q
TSK ;
 S ZTRTN="L^DIVRE",ZTDESC="REQUIRED FIELD CHECK",ZTIO=ION_";"_IOST_";"_IOM
 F N="DIC","^UTILITY($J,","DIROOT" S ZTSAVE(N)=""
 D ^%ZTLOAD X $G(^%ZIS("C")) G QQ
 ;
ALL S DIR(0)="Y",DIR("??")="^D H^DIVRE1"
 S DIR("A")="DO YOU MEAN ALL THE ENTRIES IN THE FILE"
 D ^DIR K DIR S X="ALL"
 Q

DIVRE1
DIVRE1 ;SFISC/MWE-HELP LOGIC FOR REQ FLD(S) CHK ;1/17/91  3:11 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
H W !!?5,"YES means that every entry in the file will be checked to see"
 W !?5,"that all the required fields have data."
 W !!?5,"NO means that ALL will be used to lookup an entry in the"
 W !?5,"file which begins with the letters ALL."
 Q

DIVU
DIVU ;SFISC/DCM-VERIFY FIELDS UTILITIES ;8/1/95  1:02 PM
 ;;21.0;VA FileMan;**8**;Aug 01, 1995
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
DE(FI,FD,N,G,S) ;
 Q:'$D(^DD($G(FI),0))  I $G(FD) Q:'$D(^(FD,0))
 I $G(G)']"" S G="DE"
 N Z,X,Y,%,H,D,I,J,V,K
 I $G(^DIC(FI,0))]"" S I(0)=^(0,"GL"),J(0)=+FI,V=0
 E  D IJ(FI)
 S Y=I(0),X=V,H="",Z=0
 I +$G(S),V S S=$S('$P(S,U,2):V,1:$P(S,U,2)) S Z=S,X=X-S F %=0:1 S Y=Y_"D"_%_","_I(%+1)_","  I %=(S-1) Q
L S D="D" S D=D_Z S Y=Y_D,H=H_"S "_D_"=0 F  ",%="S "_D_"=$O("_Y_"))" I V>1 S @G@(Z)=%,H=H_"X "_G_"("_(Z)_")"
 E  S H=H_%
 S H=H_" Q:"_D_"'>0  "
 S X=X-1,Z=Z+1
L1 I X<0 D  Q
 .I $G(N)]"",$G(FD)]"" D  S H=H_" X "_G_"(99)",@G=H,@G@(99)=Y Q
 . . N DN,%,%N,%P,%4,Q
 . . S Q=";",%=^DD(FI,FD,0),%(2)=$G(^(2)),%4=$P(%,U,4),%N=$P(%4,Q),%P=$P(%4,Q,2)
 . . I FD=.001,%P="" S Y="S "_N_"=D"_V Q
 . . I %P=" " D CAL Q
 . . I $G(%P)]"" S Y=Y_","_%N_")"
 . . I %P S DN="$P(",%P="),U,"_%P_")"
 . . I $E(%P)="E" S DN="$E(",%P="),"_$E(%P,2,9)_")"
 . . I $G(DN)="" Q
 . . S Y="S "_N_"="_DN_"$G("_Y_%P
 . . I %(2)]"",$P(%,U,2)["O",$P(%,U,2)'["D" S Y=Y_",Y="_N_" "_%(2)_" S "_N_"=Y"
 . . Q
 . S @G=H Q
 S Y=Y_","_I(V-X)_"," G L
 ;
CAL S Y=$P(%,U,5,99)_" S "_N_"=X" Q
 Q
IJ(FI) ;set I( and J( and V=level
 Q:'$D(^DD($G(FI),0))
 N X,Y,S,Q,F S X=0,(S,Y)=FI,Q="""" F  Q:'$D(^DD(Y,0,"UP"))  S X=X+1,Y=^("UP")
 S V=X I X'=0 F X=X:-1 S Y=$G(^DD(S,0,"UP")) Q:'Y  S F=$O(^DD(Y,"SB",S,0)) Q:'F  S I(X)=$P($P($G(^DD(Y,F,0)),U,4),";"),K(X)=$O(^DD(S,0,"NM","")),J(X)=S,S=Y S:I(X)'=+I(X) I(X)=Q_I(X)_Q
 S I(0)=$G(^DIC(S,0,"GL")),J(0)=S
 Q
DA(Z) ;convert D0,D1... to DA()
 N A,B,C,D K Z
 F A=0:1 S D="D"_A Q:'$D(@D)
 S C=0,A=A-1 F B=A:-1:0 S Z(B)=@("D"_C),C=C+1
 S Z=Z(0) K Z(0)
 Q
DIBT(X,%,S) ;lookup sort template, return template's IEN
 N DIC,Y
 S X=$E(X,2,$L(X)-1),DIC="^DIBT(",DIC("S")="I $P(^(0),U,4)="_S,DIC(0)="ZM" D ^DIC
 S %=+Y
 Q

DIWE
DIWE ;SFISC/GFT,XAK-START OF WP ;10/4/94  11:33
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN K DTOUT,DUOUT,DIRUT ;G Q:'$D(@(DIC_"0)")) D A
 L @("+"_DIC_"0):1") E  W !,"FILE IS IN USE BY ANOTHER TERMINAL" G Q
 D A
OPT K:DIWE'=2 DDWC,DDWRW I DIWE>1 S DIWE(2)=1 G OPT^DIWE12
GO S:$D(DTIME)[0 DTIME=300 ;I $D(DT)[0 D NOW^%DTC S DT=X K %I
 S @(DIC_"0)")=DWLC G ^DIWE1:DWLC D ^DIWE2 S (DWL,DWLC)=DWI G GO:DWL,X
 ;
DIEN ;
 I '$D(DIA) N DIA S DIA=DIE,DIA("P")=DP
 S DH=$P(Y,U,1),DV=DG,DWPK="FM",(DIC,Y)=DIE_DA_",DV",DWO="ABCDE IJLMPRSTU"_$E("Y",DUZ(0)="@") S:'$D(DIWESUB) DIWESUB=DH D A G W:'$D(DE(1,0))
 S X=DE(1,0),DWI=X?1"/".E,@(DIC_"0)")=DWLC S:DWI X=$E(X,2,999) I X?1"+".E S X=$E(X,2,999)
 E  G W:'DWI&DWLC K:DWLC @(Y_")") S DWLC=0 Q:X="@"
 I X?1"^".E S DIW=DIC,DICMX="S DWLC=DWLC+1,"_DIC_",DWLC,0)=X",DIWL=DWLC X $E(X,2,999) S DIC=DIW S:DIWL-DWLC X="" K DICMX,DIWL,DIW
 S:X]"" DWLC=DWLC+1,@(DIC_"DWLC,0)=X") G X:DWI
W W !?DL+DL-2,DH_":" G OPT
 ;
A S:$E(DIC,$L(DIC))'="," DIC=DIC_"," S:'$D(DWO) DWO="ABCDE IJLMPRS"_$E(" T",$S($G(DIA("P"))=3.9:2,1:1))_"U"_$E(" Y",$S($G(DUZ(0))="@":2,1:1))
 K DWL,DIWE S U="^",DIWPT=$S('$D(^VA(200,0)):"",^(0)'["NEW PERSON":"",'$D(^VA(200,+DUZ,1)):"",1:$P(^(1),U,4))
 S DIWE=$S('$D(^VA(200,0)):0,^(0)'["NEW PERSON":0,'$D(^VA(200,+DUZ,1)):0,1:+$P(^(1),U,5)),DIWE=$S($D(^DIST(1.2,DIWE,0)):DIWE,1:0) S:'DIWE DIWE=$S($D(DDS)#2:2,1:1)
 S @("J=$O("_DIC_"0))>0") I '$D(^(0))!'J S ^(0)=""
 S DWHD=^(0)_U,DWLC=+$P(DWHD,U,3),DWLW=$S($D(DWLW):DWLW,1:245) I J D REPACK:DWLC-$P(DWHD,U,4)!'DWLC!'$D(^(DWLC))
 S DWPK=$S($D(DWPK):DWPK,1:2),DWLR=245,DWLC=$S('DWLC:+DWHD,1:DWLC)
 Q
 ;
REPACK K ^UTILITY($J,"W") S J=0 F I=0:0 S @("J=$O("_DIC_"J))") Q:J'>0  S:$D(^(J,0)) I=I+1,^UTILITY($J,"W",I)=^(0) W:'$D(ZTQUEUED) "."
 K @($E(DIC,1,$L(DIC)-1)_")") F J=1:1:I S @(DIC_"J,0)=^UTILITY($J,""W"",J)") W:'$D(ZTQUEUED) "."
 K ^UTILITY($J,"W") S DWLC=I,$P(@(DIC_"0)"),U,3,4)=I_U_I Q
 ;
X Q:$D(DIWE(1))  I $D(DT)[0 D NOW^%DTC S DT=X K %I ;
 I @("$O("_DIC_"0))'>0") K @($E(DIC,1,$L(DIC)-1)_")") G Q
 I $D(@(DIC_"0)"))#2 G Q:$P(^(0),U,5)?7N.1P.6N ;Has already been updated.
 S ^(0)=$P(DWHD,U,1,2)_U_DWLC_U_DWLC_U_DT_U_$P(DWHD,U,6,9)
Q L @("-"_DIC_"0)") K DW2,DW3,DIWPT,DWO,DWLR,DWHD,DWL,DWPK,DWI,DWJ,DWLC
 K Y,Z,DWAFT,DWLW,DIW,D,DIWE,DIWETXT,DIWESUB,DDWLMAR,DDWRMAR,DC Q

DIWE1
DIWE1 ;SFISC/GFT-WORD PROCESSING FUNCTION ;7/29/94  09:18
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 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
1 G X:$D(DTOUT) R !,"EDIT Option: ",X:DTIME S:'$T DTOUT=1 G X:U[X!(X=".")
LC I X?1L S X=$C($A(X)-32)
 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
 I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWO,I) I X]"" W X S I=I*2-1 G OPT
 I X?1N.N S I=9 D LN G E2:X W "OR"
 W !?5,"Choose, by first letter, a Word Processing Command"
 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)
 W !?5,"or type a Line Number to edit that line." G 1
 ;
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)
A ;;Add lines;Add Lines to End of Text
 D ^DIWE2 S (DWL,DWLC)=DWI,@(DIC_"0)=DWLC") G 1:DWLC,X
B ;;Break line: ;Break a Line into Two;
 D RD G B^DIWE4
C ;;Change every: ;Change Every String to Another in a Range of Lines;
 G C^DIWE2
D ;;Delete from line: ;Delete Line(s);
 D RD G D^DIWE3
E ;;Edit line: ;Edit a Line (Replace __  With __);
 D RD G OPT:X="",1:X=U,LC:X?1A,E2
G ;;Get Data from Another Source ;Get Data from Another Source
 G X^DIWE5
I ;;Insert after line: ;Insert Line(s) after an Existing Line;
 D RD G I^DIWE2
J ;;Join line: ;Join Line to the One Following;
 D RD G J^DIWE4
L ;;List line: ;List a Range of Lines;
 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
M ;;Move line: ;Move Lines to New Location within Text;
 D RD G M^DIWE3
P ;;Print from Line: 1//;Print Lines as Formatted Output;
 R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=1 D LN,^DIWE4:X G 1
R ;;Repeat line: ;Repeat Lines at a New Location
 D RD G R^DIWE3
S ;;Search for: ;Search for a String
 G S^DIWE2
T ;;Transfer incoming text after line: ;Transfer Lines From Another Document
 D RD,Z^DIWE3 G DIWE1
U ;;Utilities in Word-Processing;Utility Sub-Menu
 D ^DIWE11 G 1
Y ;;Y;Y-Programmer Edit;
 G Y^DIWE4
 ;;
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."^"
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
 S:X]"" ^(0)=X I X="@" S (DW1,DW2)=DWL W "DELETED..." D DEL^DIWE3
 W ! S I=9 G OPT
 ;
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
LN I U[X!(X=".") S X=U Q
 Q:I=9&(X?1A)  I 'DWLC,I<27,I-13 S X=U W "  THERE ARE NO LINES!",$C(7),! Q
 I "+- "[$E(X,1),X?1P.N,$D(DWL) S:X?1P X=X_1 S X=X+DWL W "  "_X
 E  S X=+X
 I (I=13!(I=27)&(X=0))!$D(@(DIC_"X,0)")) S DWL=X Q
 S X="" G LNQ^DIWE5
 ;
X K DIWELAST
 G X^DIWE
 ;
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
 S J=X,DIWELAST=$S(DWLC=I:1,1:I) D LL G 1
LL X "F J=J:1:I W !,$J(J,3)_"">""_"_DIC_"J,0)"

DIWE11
DIWE11 ;SFISC/GFT,MWE-WORD PROCESSING UTILITY FUNCTION ;3/4/92  9:55 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DWOU="EFT"
1 R !,"UTILITY Option: ",X:DTIME S:'$T DTOUT=1 G QQ:U[X!(X=".")
LC I X?1L S X=$C($A(X)-32)
 S J="^DOPT(""DIWE11""," I X?1U S I=$F(DWOU,X)-1 I I>0 S ^DISV(DUZ,J)=I S I=I*2-1 G OPT
 I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWOU,I) I X]"" W X S I=I*2-1 G OPT
 W !?5,"Choose, by first letter, a Utility Command"
 I X?2"?".E W " from the following:" F I=1:2 S Y=$T(OPT+I),J=$E(Y,1) Q:J=" "  I DWOU[J W !?10,$P(Y,";",4)
 G 1
 ;
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)
E ;;Editor;Editor Change
 G ^DIWE12
F ;;File transfer;File Transfer from Foreign CPU
 G NA:'$D(^%ZOSF("EON"))!'$D(^("EOFF")) D X^DIWE5 G QQ
T ;;Text-Terminator;Text-Terminator-String Change
 D TT G QQ
 ;;
TT ;
 W !,"Text-Terminator: ",$S(DIWPT="":"<NULL-STRING>",1:DIWPT),"//"
 R X:DTIME S:'$T DTOUT=1 Q:U[X
 K:$L(X)>5!(X'?.ANP)!(X["?")!(X["^") X
 I '$D(X) W !?5,"Answer must be 1 to 5 Characters, no question marks or up-arrows,",!?5,"to go back to the Null-String just type ""@"" !",$C(7) G TT
 I X="@" W !?5,"Text-Terminator is now Null-String !" S X=""
 S DIWPT=X Q
QQ K DWOU Q
ASK W ! S DIR("A")="MAXIMUM string length? "
 S DIR("B")=75,DIR(0)="N^3:245:0" D ^DIR K DIR I $D(DIRUT) S X="" G XQ1
 W !!,"You have 30 seconds to start sending text."
 W !,"An End Of File is assumed on 30 second time-out."
 W !!,"TABs are converted to 1 thru 9 spaces to start the next character"
 W !,"at a column evenly divisable by 9 plus 1. (10,19,28,37...)"
 W !!,"End of Line = Carriage Return/$C(13) or Escape/$C(27)."
 W !,"All other control characters will be stripped.",!!
 Q
XQ X ^%ZOSF("EON") W !!,"File Transfer Complete",$C(7),!
XQ1 K %,%1,%2,%B,%0,DIWL,DIR,DIRUT,DIROUT,DTOUT,DUOUT
 Q
NA W !!,"This option is not available without the rest of the KERNEL"
 G QQ

DIWE12
DIWE12 ;SFISC/XAK,RWF-WORD PROCESSING CHANGE EDITORS ;9/27/94  09:59
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q:$D(DIWE(1))  S DIWE(1)=DIWE D 1 K DIWE(1) Q
 ;
1 I '$D(DIWE(9)) D ASK G QX:U[X
2 S DIWE=DIWE(9) K DIWE(9) I $D(DIWE(1)),DIWE=DIWE(1) K DIWE(1) Q
OPT S DIWE(5)=$G(^DIST(1.2,DIWE,2)) I DIWE(5)]"" X DIWE(5) I '$T S:$D(DIWE(2)) DIWE(9)=1 G 1 ;Not valid
 Q:$D(DTOUT)  S @(DIC_"0)")=DWLC,DIWE(0)=$S($D(^DIST(1.2,DIWE,1)):^(1),1:"") I $G(DIWE)=1!$D(DDS)!$D(DIWE(1))!($G(DWPK)'="FM"&($D(DIWEPSE)[0)) X DIWE(0) G QQ
 K DIR I $G(DWPK)'="FM" S DIR(0)="E"
 E  D
 . N I,J
 . W:'DWLC !,$J("",$G(DL)*2)_"No existing text"
 . I DWLC S I=DWLC,J=$S(I<11:1,1:I-8) W:J>1 ?7,". . .",!?7,". . ." X "F J=J:1:I W !,"_DIC_"J,0)" W !
 . S DIR(0)="Y",DIR("A")=$J("",$G(DL)*2)_"Edit",DIR("B")="NO",DIR("?",1)="    Enter 'YES' if you wish to go into the editor.",DIR("?")="    Enter 'NO' if you do not wish to edit at this time."
 . Q
 D ^DIR K DIR I '$D(DIRUT),Y=1 X DIWE(0)
QQ K DIWEPSE I $D(DIWE(1)) S DIWE=DIWE(1),DIWE(5)=$G(^DIST(1.2,DIWE,3)) X:DIWE(5)]"" DIWE(5)
QX K DWOU I $D(DIWESW) K DIWESW G:'$D(DIWE(1)) 1
 D:$D(DIWE(2)) X^DIWE Q
 ;
ASK R !,"Select ALTERNATE EDITOR: ",X:DTIME S:'$T DTOUT=1,X=U G AQ:U[X!(X=".")
 I X'?.UNP S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 S Y=X I X?1U.ANP,'$D(^DIST(1.2,"B",X)) S X=$O(^(X)) S:$E(X,1,$L(Y))'=Y X="?"
 S J="^DIST(1.2," I X?1U.UNP S I=$O(^DIST(1.2,"B",X,0)) I I>0 S ^DISV(DUZ,J)=I,DIWE(9)=I W $P(X,Y,2) G AX
 I X=" ",$D(^DISV(DUZ,J)) S I=^(J) I $D(^DIST(1.2,I,0))#2 S DIWE(9)=I,X=$P(^(0),U,1) W X G AX
 W !?5,"Choose an Alternate Editor"
 I X?2"?".E W " from the following:" S Y="" F I=0:0 S Y=$O(^DIST(1.2,"B",Y)) Q:Y']""  S DIWE=+$O(^(Y,0)),DIWE(5)=$G(^DIST(1.2,DIWE,2)) I 1 X:DIWE(5)]"" DIWE(5) I $T W !?10,Y
 G ASK
AQ S X=U
AX Q
 ;
 ;DIC is the root of the where the text is located.
 ;DWLC is the line count, must be updated by the editor.
 ;The @(DIC_"0)") node will be updated by DIWE on exit.
 ;Variables not to be changed:
 ;DWHD,DIWPT,DWO,DWLR,DWL,DWPK,DWAFT,DIWE
 ;DIWE = Pointer to current editor
 ;DIWE(0) = Calling code
 ;DIWE(1) = if $D Called from this editor, will return at end.
 ;DIWE(2) = if $D Flag to say prefered editor not R/W used in exit.
 ;DIWE(5) = if $D Other execute code for OK TO RUN, RETURN TO CALLING
 ;DIWE(9) = if $D then entry number of editor to switch to.

DIWE2
DIWE2 ;SFISC/GFT-WP SEARCH, CHANGE, INSERT ;4/12/94  1:15 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DWI=DWLC,DWJ=0,DWLR=DWLW I DWLC W !,$J(DWLC,3),">",@(DIC_DWLC_",0)")
NEWL W !,$J(DWJ+DWI+1,3),">" R X#245:DTIME I '$T,X="" S DTOUT=1 Q
 I X="",DIWPT'="" S X=" "
 Q:U[X!(DIWPT=X)
 I X?."?" D IQ^DIWE5 G NEWL
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
 I X'?.ANP W $C(7),!?9,"CONTROL CHARACTERS REMOVED!!",! F Y=1:1 I $E(X,Y)?.C G:Y>$L(X) NEWL:X="",G S X=$E(X,1,Y-1)_$E(X,Y+1,999),Y=Y-1
G G NW:'DWPK,NW:X?." "!(X[($C(124)_"TAB"_$C(124)))!($A(X)=124),NL:DWPK=1 S:DWI Y=@(DIC_DWI_",0)") S J=$L(X) I J+DWLR<DWLW S @(DIC_"DWI,0)")=Y_$E(" ",$A(Y,DWLR)'=32)_X,DWLR=$L(@(DIC_"DWI,0)")) G NEWL
 I DWLR+7<DWLW F J=DWLW-DWLR:-1:1 IF $E(X,J)=" " S @(DIC_"DWI,0)")=Y_$E(" ",$A(Y,DWLR)'=32)_$E(X,1,J-1),X=$E(X,J+1,256),DWLR=$L(X) Q
NL I $L(X)>DWLW S J=$F(X," ",DWLW-7),J=$S(J<1!(J>DWLW):DWLW,1:J),DWI=DWI+1,@(DIC_"DWI,0)")=$E(X,1,J-1),X=$E(X,J,256),DWLR=J G NL
 S:$L(X) DWI=DWI+1,@(DIC_"DWI,0)")=X,DWLR=$L(X) G NEWL
NW S:$L(X) DWI=DWI+1,@(DIC_"DWI,0)")=X,DWLR=DWLW G NEWL
 ;
I ;INSERT
 G 1:X=U,OPT^DIWE1:X=DIWPT S DWJ=X W:X !,$J(DWJ,3),">",^(0) K ^UTILITY($J,"W") S DWI=0,DIC(1)=DIC,DIC="^UTILITY($J,""W"",",@(DIC_"0)")="",DWLR=DWLW D NEWL G D:'DWI
 W !,DWI_" line"_$E("s",DWI'=1)_" inserted.."
 X "F DWL=DWI+DWLC:-1:DWJ+DWI+1 S "_DIC(1)_"DWL,0)="_DIC(1)_"DWL-DWI,0) W ""."""
 X "F DWL=DWI:-1:1 S "_DIC(1)_"DWJ+DWL,0)="_DIC_"DWL,0) W ""."""
D S DWLC=DWLC+DWI,DIC=DIC(1) K ^UTILITY($J,"W"),DIC(1)
1 G ^DIWE1
 ;
S ;SEARCH
 R X:DTIME S:'$T DTOUT=1 I X]"" W " ...",! X "F I=1:1:DWLC I "_DIC_"I,0)[X W $J(I,3)_"">""_^(0),! S DWL=I"
 G 1^DIWE1
 ;
C ;CHANGE
 R DWI:DTIME S:'$T DTOUT=1 G 1:DWI="" R " to: ",DWJ:DTIME S:'$T DTOUT=1 G 1:'$T
 W !,"Ask 'OK' for each line found" S %=2 D YN^DICN G 1:%<1
FR R !,"From line: 1// ",X:DTIME S:'$T DTOUT=1 G 1:X=U!'$T I X="" S J=1 G TO
 D LN^DIWE1 G FR:X="",1:X=U S J=X
TO W "   to line: "_DWLC_"// " R I:DTIME S:'$T DTOUT=1 G 1:X=U!'$T I I="" S I=DWLC
 I I<J!'I W $C(7),"??" G FR
 I I>DWLC S I=DWLC W "  ("_I_")"
 W " ...",! X "F J=J\1:1:I I "_DIC_"J,0)[DWI D C1"
 G 1
C1 S Y=0,DWL=^(0) I %=1 W $J(J,3)_">"_DWL R !,"OK to change? YES// ",X:DTIME,! S:X=U!'$T J=I S:'$T DTOUT=1 Q:"YESyes"'[X!'$T
C2 S Y=$F(DWL,DWI,Y) I Y S DWL=$E(DWL,1,Y-$L(DWI)-1)_DWJ_$E(DWL,Y,999),Y=Y-$L(DWI)+$L(DWJ) G C2
 W $J(J,3)_">"_DWL,! S ^(0)=DWL,DWL=J

DIWE3
DIWE3 ;SFISC/GFT-WP - MOVE, DELETE, REPEAT, TRANSFER ;8/3/94  1:36 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
M ;MOVE
 S DWAFT=1 G 1:X=U,OPT:'X S (DW1,DW3)=0 D MOVE Q:$D(DTOUT)  S:DW1>DW3 DW1=DW1+I,DW2=DW2+I D DEL:DW1
1 G ^DIWE1
 ;
OPT W ! G OPT^DIWE1
 ;
R ;REPEAT
 S DWAFT=1 G 1:X=U,OPT:'X D MOVE
 G 1
 ;
D ;DELETE
 S DW1=X G 1:X=U,OPT:'X W "  thru: "_DW1_"// " R DW2:DTIME S:'$T DTOUT=1
 G 1:DW2=U!'$T S:DW2="" DW2=DW1 I DW1>DW2 W $C(7),"??" G OPT
 I DW2>DWLC S DW2=DWLC W "  ("_DW2_")"
 S X=DW2-DW1+1,%=2 W !,"OK TO REMOVE "_X_" LINE"_$E("S",X>1)
 D YN^DICN I %-1 W "  <NOTHING DELETED>" G 1
 S %=2 I DW1=1,DW2=DWLC W !,$C(7),"ARE YOU SURE YOU WANT TO DELETE THIS ENTIRE TEXT" D YN^DICN G 1:%-1
 D DEL K DWL G 1
 ;
F R !,"From line: ",DWL:DTIME S:'$T DTOUT=1 G Q:DWL=U!'$T
 I DWL?."?" D H^DIWE5 G F
 I +DWL'=DWL W $C(7)," ??    Please enter a number." G F
MOVE R "  thru: ",DW2:DTIME S:'$T DTOUT=1 G Q:DW2=U!'$T S DW1=DWL
 I $E(DW2)="E"!($E(DW2)="e") S DW2=9999999
 I 'DW2 S DW2=DW1 W " (",DW1,")"
 S %=2 G YN:'DWAFT R " after line: ",DW3:DTIME S:'$T DTOUT=1 G Q:DW3=U!'$T
 I DW1-1<DW3,DW2>DW3 G Q
 I DW1<1!(DW2>DWLC)!(DW1>DW2)!(DW3<0)!(DW3>DWLC)!(+DW3'=DW3) G Q
YN W !,"ARE YOU SURE" D YN^DICN
 G Q:%-1 K ^UTILITY($J,"W") S I=0
 I DWAFT?.N X "S J=DW1-.1 F  S J=$O("_DIC_"J)) Q:J>DW2!(J'>0)  I $D(^(J,0)) S X=^(0) D O" S:J="" J=-1 G DN
 S DICMX=DWAFT X X S DIC=DWI
DN G Q:'I X "F J=DWLC:-1:DW3+1 S "_DIC_"J+I,0)="_DIC_"J,0)","F J=1:1:I S "_DIC_"DW3+J,0)=^UTILITY($J,""W"",J,0) W ""."""
 K ^UTILITY($J,"W"),DWL,X,DICMX S DWLC=DWLC+I,@(DIC_"0)")=DWLC Q
 ;
DEL S I=+DW1
 X "F J=DW2+1:1:DWLC S "_DIC_"I,0)="_DIC_"J,0),I=I+1 W ""."""
 S I=DW2-DW1
 X "F J=DWLC-I:1:DWLC K "_DIC_"J) W ""."""
 S DWLC=DWLC-I-1 Q
 ;
Z ;
 Q:X=""  S DWAFT=0,DW3=X Q:X[U!(X>DWLC)  I '$D(DIA("P")) G Q
 R !,"From what text: ",X:DTIME S:'$T DTOUT=1 G Q:U[X
 I X?1."?" D  G Z
 .N X,Y,D,DIC,DIR,DZ,DIX,DIY,DIZ,DO,DD
 .W !! I DIA("P")=3.9 W ?5,"Enter the message number or SUBJECT of another mailman message, OR"
 .I DIA("P")'=3.9 W ?5,"Select another entry in this file OR"
 .W !?5,"use relational syntax to pick up information from a word-processing",!?5,"field in another file.",!
 .W ?5,"ex.  ""VALUE"":FILE NAME:WORD PROCESSING FIELD NAME",!
 .W !,"Do you want the entire "_$O(^DD(DIA("P"),0,"NM",0))_" list?"
 .S DZ="??" S DIR(0)="Y" D ^DIR Q:'Y
 .S DIC=$S(DIA("P")=3.9:"^XMB(3.9,",1:DIE),DIC(0)="QEM",D="B" D DQ^DICQ
 .Q
 I DIA("P")=3.9 S:X?1.N X="`"_X S DP=DIA("P"),DC="1^3.92A",DIE="^XMB(3.9,"
 K I,J S DWI=DIC,DWAFT=$S($D(DA)#2:DA,1:0)
 S DICMX="D O:D'<DW1&(D'>DW2) K:D>DW2 D",DQI="Y(",DA="X(",I(0)=DIA
 S J(0)=DIA("P"),DICOMP="?" I X?1"`"1N.N I $D(@(DIE_+$P(X,"`",2)_",0)")) S DWAFT(2)=X,X=$P(^(0),U,1)
 I X?.ANP S @("I=$O("_DIE_"""B"",$E(X,1,30)))") S:I="" I=-1 I $P(I,$E(X,1,30))=""!$D(^($E(X,1,30)))!(X?1."?") S X=""""_X_""":"_$O(^DD(DP,0,"NM",0))_":"_$O(^DD(+$P(DC,U,2),0,"NM",0))
 D DICOMP
 S DIC=DWI,DA=DWAFT,DWAFT=U I '$D(X) G Q
 I $G(Y)'["w" D  I $G(DIRUT) K DIRUT G Q
 .W $C(7),!!,"WARNING!",!,"The field you are transferring text from displays text without wrapping."
 .W !,"The field you are transferring text into may display text differently."
 .W !!,"Do you want to continue?",! N X,Y,DIR S DIR(0)="Y" D ^DIR
 .W ! S:'Y DIRUT=1
 G Q:X'["D ^DIC" D  I Y<0 K DWAFT S DIC=DWI G Z:X?1."?",Q
 .S %=$F(X,"D ^DIC"),%=$F(X," ",%)-1,DWAFT=$E(X,1,$F(X,"S X=")-6),DWAFT(1)=$E(X,%,999)
 .X $P(X," D ^DIC") S DIC(0)="QEM" S:$G(DWAFT(2))]"" X=DWAFT(2) D ^DIC
 I DIC["^XMB(3.9,",$D(XMZ) S DIXM=XMZ X "N X D XM" K DIXM
 S DIC=DWI I X'[U S X=DWAFT_" S Y="_+Y_DWAFT(1) K DWAFT S DWAFT=U G F
Q W "  <NO CHANGE>",$C(7) S DW1=0 K DWL,X,DICMX,DWAFT Q
O S I=I+1,^UTILITY($J,"W",I,0)=X Q
 ;
DICOMP I DIA("P")=3.9 S %=DUZ N DUZ S DUZ=%,DUZ(0)="@"
 D ^DICOMP Q
 ;
XM W !,"Transfer from Response: Original Message// " R X:DTIME Q:X[U
 I X?1."?" S XMZ=+Y D ENT8^XMAH S Y=XMZ,XMZ=DIXM G XM
 I X,$D(^XMB(3.9,+Y,3,X,0)) S Y=+^(0) Q
 I X=""!(X=0)!(X="O") Q
 G XM

DIWE4
DIWE4 ;SFISC/GFT-WP - ROUGH DRAFT, BREAK, JOIN ;4/22/93  10:37 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W " to Line: "_DWLC_"// " R DW2:DTIME S:'$T DW2=U,DTOUT=1 S:DW2="" DW2=DWLC Q:DW2>DWLC!(DW2<X)  S DW2=+DW2
 S:$D(DV)[0 DV=0 S %=2 W !,"WANT LINE NUMBERS" D YN^DICN Q:%<1  S I=%,J=0
RD I I=1 S %=2 W !,"ROUGH DRAFT" D YN^DICN Q:%<0  S:%=1 J=124 I %=0 W !,"A Rough Draft is printed line-for-line, showing windows.",! G RD
D0 ;Entry point for screen editor.
 S DIWF="W"_$S(J:"N",DWPK="FM"&$D(DQ(1)):$E("N",$P(DQ(1),U,2)["L"),1:"")_$E("L",I)_$C(J)
 K DW1,IOP,I,J D:'$D(DISYS) OS^DII I $D(^%ZTSCH("RUN")),$D(^%ZOSF("UCI")),$D(^DD("OS",DISYS,8)) S %ZIS="QM"
 D ^%ZIS G K:POP
 S DIWR=IOM-(DIWF["L"*4),DIWL=1,DWI="F D=DWL:0 S X="_DIC_"D,0) D ^DIWP S D=$O("_DIC_"D)) Q:(D'>0)!(D>"_DW2_")  I '(D#60),$D(ZTQUEUED),$$S^%ZTLOAD S X=""***TASK STOPPED***"" D ^DIWP S ZTSTOP=1 Q",DWJ=0
 I DWPK'="FM" S DWH="Line Editor Print" G QUE
 S:$G(DIEL)="" DIEL=DL-1 S DW1=DIE,DW2=DA,%=DIEL,I(%)=DIE,J(%)=DP,I(%,0)=DA,DWH=$S($D(DQ)<11:"",1:$E($P(DQ(DQ),U,1),8,99))
DWH S DWH=$O(^DD(J(%),0,"NM",0))_$P(" FILE",1,'%)_":"_DWH I @("$D("_I(%)_I(%,0)_",0))") S DWH=""""_$P(^(0),U,1)_""" IN "_DWH
 S %=%-1 I %+1,$D(DP(%+1)),$D(DIE(%+1)),$D(DA(DIEL-%)) S J(%)=DP(%+1),I(%)=DIE(%+1),I(%,0)=DA(DIEL-%) G DWH
QUE I '$D(IO("Q")) D PRNT G X
 S DIR(0)="D^::AEFR",DIR("A")="REQUESTED TIME TO PRINT",DIR("B")="NOW",DIR("?")="Enter a date with a time" D ^DIR G:$D(DIRUT) X S ZTDTH=Y
 S ZTRTN="PRNT^DIWE4",ZTDESC=DWH
 F %="DIC","DIWF","DIWL","DIWR","DV","DWH","DWI","DWJ","DWL","DW2","D0","I","J","I(","J(" S ZTSAVE(%)=""
 D ^%ZTLOAD S IOP="HOME" D ^%ZIS W "  REQUEST QUEUED!",! K ZTSK G X
 ;
PRNT S ^UTILITY($J,1)="S DWJ=DWJ+1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W ?3,DWH,?IOM-22,"" "" S Y=DT D DT^DIO2 W ""   PAGE "",DWJ,!!"
 I $E(IOST)="C" S DIFF=1
 U IO X ^(1),DWI D ^DIWW W:$E(IOST)'="C"&($Y) @IOF D CLOSE^DIO4
 I $D(ZTQUEUED) S ZTREQ="@"
 Q
 ;
X S:$D(DW1) DIE=DW1,DA=DW2
K K %,I,J,X1,DIWF,DIWL,DIWR,DIWT,DIWLL,DISYS,DW1,DW2,DWJ,DWH,DIFF,DIR,POP,^UTILITY($J,1) Q
 Q
 ;
Y ;
 Q:DUZ(0)'["@"
 R !!,"The text is in X and returned in Y",!,"Enter MUMPS xecute string to do transformation: ",X:DTIME S:'$T DTOUT=1 G 1:X'?1U.E D ^DIM G 1:'$D(X) S DW=X
 R !,"Edit from line: 1// ",DW1:DTIME S:'$T DTOUT=1 G 1:DW1=U!'$T S:DW1="" DW1=1 G 1:+DW1'=DW1 W "  thru: ",DWLC,"// " R DW2:DTIME S:'$T DTOUT=1 G 1:DW2=U!'$T S:DW2="" DW2=DWLC
 IF (DW1>DW2)!(DW2>DWLC)!(DW1<1) G 1
 F I=DW1:1:DW2 S X=@(DIC_"I,0)") K Y X DW I $D(Y)=1 S @(DIC_"I,0)")=Y W !,$J(I,3)_">"_Y S DWL=I
 G 1
 ;
B ;BREAK
 G 1:X=U,OPT:'X
BA R !," after character(s): ",X:DTIME S:'$T DTOUT=1 G 1:U[X S DW=^(0) I DW'[X W $C(7),"??" G BA
 S DWLC=DWLC+1 X "F I=DWLC:-1:DWL+1 S "_DIC_"I,0)="_DIC_"I-1,0) W ""."""
 S @(DIC_"0)")=DWLC,Y=$F(DW,X)-1,@(DIC_"DWL,0)")=$E(DW,1,Y),@(DIC_"DWL+1,0)")=$E(DW,Y+1,999)
 W !,$J(DWL,3)_">",@(DIC_"DWL,0)"),!,$J(DWL+1,3)_">",@(DIC_"DWL+1,0)")
1 G ^DIWE1
 ;
OPT W ! G OPT^DIWE1
 ;
J ;JOIN
 G 1:X=U,OPT:'X I X=DWLC W $C(7),"??" G OPT
 S @("Y="_DIC_"X+1,0)"),@("J="_DIC_"X,0)") I $L(Y)+$L(J)>250 W $C(7),"  TOO LONG" G 1
 S ^(0)=J_" "_Y W !,$J(X,3)_">"_^(0),! F I=X+1:1:DWLC-1 S @(DIC_"I,0)="_DIC_"I+1,0)") W "."
 K @(DIC_"DWLC)") S DWLC=DWLC-1 G 1

DIWE5
DIWE5 ;SFISC/GFT-WP, AUX FUNCTIONS ;8/3/94  1:11 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
LNQ ;
 W !,"ANSWER WITH A LINE NUMBER ("_(I'=6)_$P("-"_DWLC,U,DWLC>1)_")"
 I $D(DWL) W !?9,"OR A SPACE TO MEAN THE CURRENT LINE ("_DWL_")" W:DWL>2 !?9,"OR '-' TO MEAN LINE ",DWL-1,", '-2' TO MEAN ",DWL-2,", ",$P("'+' TO MEAN "_(DWL+1)_", ",U,DWL<DWLC)_"ETC."
 W ! Q
 ;
WL W !,"INITIALS:",! S X=$P(DIC,"(",1) Q:$D(@X)<9  S X=$O(@(X_"(0)"))-1,I=0 F  S X=$O(^(X)) Q:X=""  W X,!
 S X=-1 Q
NL W !,"TEXT NAMES:",! S %T2="",I=0 F  S %T2=$O(@(DW_")")) Q:%T2=""  W %T2,?20,^(%T2,0),!
 K %T2 Q
 ;
F ;
 W !!,"Line WIDTH: "_DWLW_"//" R X:DTIME S DWLW=$S(X<10:DWLW,X>255:DWLW,1:X\1)
 W !,"PACK "_$S(DWPK:"ON",1:"OFF")_"//" R X:DTIME S DWPK=$S(X="ON":1,1:0)
 Q
X D ASK^DIWE11 Q:X=""  S DIWL=X,(%,%B)="" X ^%ZOSF("EOFF")
ENT I '$D(DIWL) S DIWL=245
A R X#245:30 E  I '$L(X) D S:$L(%B) G XQ^DIWE11
 S:X="" X=" " I X?.ANP S Y=X G D
 S I=0,Y=""
C S I=I+1 I $E(X,I,999)?.ANP S Y=Y_$E(X,I,999) G D
 S %=$E(X,I),%0=$A(%)
 I %?1C S %="" I %0=9 S %=$E("         ",1,9-($L(Y)-($L(Y)\9*9)))
 S Y=Y_% D S:$L(Y)>DIWL I ":27:13:"[(":"_%0_":") D S
 G C
D D S G D:$L(Y)'<DIWL S %B=Y,Y="" G A
S S:$L(%B) %B=%B_$S($E(Y)=" ":"",1:" ") S %=%B_Y,%2=$L(%) Q:'%2  S Y=""
 I %2>DIWL F %1=DIWL:-1 I %1<$S(DIWL-12>0:DIWL-12,1:4)!(" -"[$E(%,%1)) S Y=$E(%,%1+1+$S($E(%,%1+1)=" ":1,1:0),999),%=$E(%,1,%1-$S($E(%,%1)=" ":1,1:0)) Q
 S %B="",DWLC=DWLC+1,@(DIC_"DWLC,0)")=%
 Q
TQ ;
 W !?4,"IF YOU WANT TO USE TEXT FROM THE '"_J_"' FIELD",!?4,"OF ANOTHER '"
 W I,"' ENTRY, TYPE THE NAME OF THAT ENTRY",!?4,"OTHERWISE, "
 W "USE A COMPUTED-FIELD EXPRESSION TO DESIGNATE SOME W-P TEXT",!
 G Z^DIWE3
 ;
H ;
 N I,%,DIWED,Y,Z
 F I=0:1 Q:'$G(@("D"_I))  S DIWE(I)=@("D"_I)
 S %="",Z=X F  S %=$O(X(%)) Q:%=""  S Z(%)=X(%)
 S I=1 F  S %=$O(X(I)) Q:$F(X(%),"D O")!(%="")
 G Q:%=""
 S Y(%)=$E(X(%),1,$F(X(%),"D O")-1)_" Q:X=U!$D(DTOUT)",%(%)=X(%),X(%)=Y(%)
 S %=X X "N X",%
 F I=0:1 Q:'$G(DIWED(I))  S @("D"_I)=$G(DIWED(I))
 S X=Z,%="" F  S %=$O(Z(%)) Q:%=""  S X(%)=Z(%)
Q K %,DIR,DIRUT,DUOUT Q
O ;
 W !,$J(D,3),">",X
 I D#15=0 S DIR(0)="E" D ^DIR
 Q
 ;
IQ ;
 I $D(DC) W:$D(^DD(+$P(DC,U,2),.01,3)) !?4,^(3),! X:$D(^(4)) ^(4) F %=0:0 S %=$O(^DD(+$P(DC,U,2),.01,21,%)) Q:%'>0  W !,^(%,0)
 W !!,"You are ready to enter a line of text.",!,"If you have no text to enter,just ",$S(DIWPT="":"press the return key.",1:"type in """_DIWPT_"""."),!
 W "Type 'CONTROL-I' (or TAB key) to insert tabs.",!
 W "When text is output, these formatting rules will apply:"
 W !," A)  Lines containing only punctuation characters, or lines containing tabs",!?5,"will stand by themselves, i.e., no wrap-around."
 W !," B)  Lines beginning with spaces will start on a new line."
 W !," C)  Expressions between '|' characters will be evaluated as"
 W !?5,"'computed-field expressions and then be printed as evaluated"
 W !?5,"thus '|NAME|' would cause the current name to be inserted in the text."
 W !!,$C(7),"Want to see a list of allowable formatting 'WINDOWS'" S %=2 D YN^DICN Q:%-1
 W !?5,"SPECIAL FORMATTING INCLUDES: "
FN S %=15 F  S %=$O(^DD("FUNC",%)) Q:%>97  I $D(^(%,10)) W !," |"_$P(^(0),U,1)_$P("(ARGUMENT)",U,$S('$D(^(3)):1,1:^(3)'=0))_"|",?25 W:$D(^(9)) ^(9)

DIWF
DIWF ;SFISC/GFT-FORMS PRINT ;2/24/93  14:33 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D DT^DICRW,DICS,L S DIC("S")=DIC("S")_" I  "_L
 S DIC="^DIC(",DIC(0)="AEQMZ",DIC("A")="Select Document File: "
 D ^DIC K DIC Q:Y<0
FINDWORD X L I '$T S Y=-1 G Q
 S DJ=%,DIC=DIWF,D=$O(^DD(DIWFN,"SB",%,0)) S:D="" D=-1 Q:'$D(^DD(DIWFN,D,0))  S D=$P($P(^(0),U,4),";") S:+D'=D D=""""_D_"""" S DIWF=DIWF_"DIWFN,"_D_","
 S D=0 F  S D=$O(^DD(DIWFN,D)) Q:D'>0  I $D(^(D,0)),$P(^(0),U,3)="DIC(" S DIWF(0)=D Q
 S:D="" D=-1
DOC S DIC(0)="AEQM" D ^DIC G Q:Y<0
 I $D(DIWF(0)) S D=$P(^DD(DIWFN,DIWF(0),0),U,4),%=$P(D,";",1) I @("$D("_DIC_+Y_",%))") S D=$P(D,";",2),X=$S(D:$P(^(%),U,D),1:$E(^(%),+$E(D,2,9),+$P(D,",",2))) S:X DIWF(1)=X
 S DIWFN=+Y I @("$O("_DIWF_"0))'>0") W $C(7),!?7,"'"_$P(Y,U,2),"' HAS NO '"_$P(^DD(DJ,.01,0),U,1)_"' TEXT!",! G DOC
EN2 ;
 I $O(@(DIWF_"0)"))'>0 S Y=-1 G Q
 S DIC(0)="AIQEMZ",DIC="^DIC(",DIC("A")="Print from what FILE: "
 I $D(DIWF(1)) S DIC(0)="ZIF",X=DIWF(1)
 D DICS:'$D(DIWF(1)),^DIC K DIC G Q:Y<0,Q:'$D(^DIC(+Y,0,"GL")) S DIC=^("GL")
 S %=1 I $D(BY)[0 W !,"WANT EACH ENTRY ON A SEPARATE PAGE" D YN^DICN G Q:%<1
 S L=0,DHD="@",FLDS="",DHIT="X "_$P("^UTILITY($J,1):$Y,",9,%)_"DIWFX D ^DIWW",DIWFX="S DIWF=""?W"",DIWL=1,DIWR=IOM,D=0 F  S D=$O("_DIWF_"D)) S:D="""" D=-1 Q:D'>0  I $D(^(D,0)) S X=^(0) D ^DIWP" K DIWF D EN1^DIP
Q K L,DIWF,DIWFN,DIWFX,DIFILE,DIAC Q
 ;
EN1 ;
 I DIC Q:'$D(^DIC(+DIC,0))  S Y=DIC D L G FINDWORD
 I @("$D("_DIC_"0))") S DIC=+$P(^(0),U,2) G EN1
 Q
 ;
DICS S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %" Q
 ;
L S L="I $D(^DIC(+Y,0,""GL"")) S DIWF=^(""GL"") I $D(@(DIWF_""0)"")) S DIWFN=+$P(^(0),U,2) I $D(^DD(DIWFN,""SB"")) S %=0 F  S %=$O(^DD(DIWFN,""SB"",%)) S:%="""" %=-1 Q:%<0  I $P(^DD(%,.01,0),U,2)[""W"" Q"

DIWP
DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;4/14/93  1:14 PM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1
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
 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
 S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z
 D NEW:DIWTC
Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z
DIW ;
 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
 S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N
 I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N
 I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X)
 S X=DIW_$P(DIWX,DIW,1)_DIW D C
N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW
D K DIWP D PUT,PRE:DIWTC Q
 ;
ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q
 ;
DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D
 Q
PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL
 Q
L ;
 S DIWTC=1 G LN
 ;
TAB I X="" S X=DIW G C
 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)
 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)
 S J=J-1-$L(DIWI) Q:J<1  S X=$J("",J)
C K DIWP I DIWTC S DIWI=DIWI_X Q
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
 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
FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,999)
S D PUT,NEW G B:X]"" Q
 ;
U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N
 S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N
 ;
NEW D DIWI
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)=""
 I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_"
 G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0))
 S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32
 S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1
 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,%(%)=%(%)_" "
PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J
 S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y
 S ^(0)=$J("",%X)_Y K %
P I DIWF["W" G NX^DIWW

DIWW
DIWW ;SFISC/GFT-OUTPUT WP LINE ;6/21/96  12:53
 ;;21.0;VA FileMan;**15**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F I=0:1 G:$D(DN) QQ:'DN Q:'$D(^UTILITY($J,"W"))  D T G:$D(DN) QQ:'DN D 0
T W:$X !
B Q:$S($D(DN):'DN,1:0)  I '$D(DIWF) S DIWF=""
 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
 F I=$Y+2:1:+$P(DIWF,"T",2) W !
 Q
 ;
A ;
 D 0 G DIWW
 ;
NX ;
 W:$X+1>DIWL ! D B G:$D(DN) Q:'DN
0 ;
 S I=999999,%=0 F  S %=$O(^UTILITY($J,"W",%)) Q:%'>0  S:$O(^(%,""))<I I=$O(^(""))
1 S %=0 F  S %=$O(^UTILITY($J,"W",%)) Q:%'>0  I $D(^(%,I)) D W I $D(^UTILITY($J,"W",%))<9 K ^(%) I $O(^(""))="" K DIWI,DIWX,DIWTC
 S:%="" %=-1 G Q
 ;
W G X:^(I,0)="",O:'$D(DIWF) I DIWF[" " S DIWF=$P(DIWF," ",1)_$P(DIWF," ",2) G X:^(0)?." "
 W:$X+1>% ! I DIWF["L",$D(^("L")) W $E(^("L")_"   ",1,4)
O W ?%-1,^(0)
X D U:$D(^("U")) I $D(^("X")) S Y=^("X") D K X Y Q
K K ^UTILITY($J,"W",%,I) Q
 ;
U Q:'$D(IOST)  Q:IOST'?1"P".E  W $C(13) F DE=1:1:$S($D(^("L")):%+3,1:%-1) W " "
 S DE=1
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
 S Y=^(%Y) K ^(%Y) I Y="" D UUU K DIWFWU G UU
 S DIWFWU=Y F DE=DE:1 G UU:DE'<%Y W " "
UUU I $D(DIWFWU) F DE=DE:1 Q:DE'<%Y  W DIWFWU
Q Q
QQ K DIWI,DIWX,DIWTC Q
 ;
RCR ;
 F DQI=1:1 I '$D(DIWF(DQI)) S DIWF(DQI)="" Q
 F M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y" I $D(@M)#2 S DIWF(DQI,M)=@M
 S DQI="Y(",DA="X(",DICMX="X DICMX",DICOMP="T" S:$D(DIA("P"))#2 J(0)=DIA("P") D EN1^DICOMP
 I '$D(X) G RESTORE:DIWF'["?"!(IO(0)=IO)!$D(IO("C")) U IO(0) W $C(7),!,$P(@(I(0)_"D0,0)"),U,1),"---",!?4,$P(DIWX,DIW,1)_": " R X:DTIME,! U IO G BACK
 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
 I Y["X" S X=DIW_X_DIW G BACK
 I $P(DIWX,"SETPAGE(",1)="" S ^(DIWL,^UTILITY($J,"W",DIWL),"X")=X,X="" G BACK
 S DICMX=Y["D" X X I DICMX S Y=X X ^DD("DD") S X=Y
 I $P(DIWX,"INDENT(",1)="" S X=$J(X,$P(DIWF,"I",2)-$L(DIWI)-1)
BACK D C^DIWP:X]"" S X="" K DICMX
RESTORE F DQI=1:1 I '$D(DIWF(DQI)) S DQI=DQI-1,M="" Q
R S M=$O(DIWF(DQI,M)) I M]"" S @M=DIWF(DQI,M) G R
 K DIWF(DQI) Q
 ;
DIQ ;
 S DIWF=$E("N",C["L")_"W|",DIWL=2,DIWR=IOM,X=O_":   " K ^UTILITY($J,"W")
 X "S W=0 F  D ^DIWP X ""N W W:$E(IOST)=""""C""""&(S>21) ! ""_DX(0) S W=$O("_D(DL-1)_"W)) Q:W'>0!(S=0)  S X=^(W,0)" S:W="" W=-1
 G DIWW
 ;
H G H^DIO2
DT G DT^DIO2
 ;
N W ! G B

DIX
DIX ;SFISC/GFT,NHRC/DRH-STATISTICS ;4/18/91  9:40 AM
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIK="^DOPT(""DIX"","
 G F:$D(^DOPT("DIX",3)) S ^(0)="STATISTICAL ROUTINE^1.01^" F I=1:1:3 S ^DOPT("DIX",I,0)=$E($T(F+I),4,99)
 D IXALL^DIK
F S DIC=DIK,DIC(0)="AEQZ" D ^DIC Q:Y<0  D @($P(Y(0),U,2,3)) W !! G DIX
 ;;DESCRIPTIVE STATISTICS^D^DIXC
 ;;SCATTERGRAM^^DIG
 ;;HISTOGRAM^^DIH
 ;;ESTIMATED LINEAR CORRELATION COEFFICIENTS^C^DIX2
 ;;COEFFICIENTS OF DETERMINATION^D^DIX2
 ;;RANDOM SAMPLE - DESCRIPTIVE STATISTICS^RS^DIX3
 ;;GENERATE RANDOM NUMBERS (WITH REPLACEMENT)^R^DIX3
DHDR ;
 S:$D(^%ZTSK) %ZIS="Q" D ^%ZIS Q:POP!$D(IO("Q"))
DQ U IO S:+DHDR'=0 DIXMM=+DHDR S:'$D(DHDR) DHDR="" I DHDR="" G HDR
 I $E(IOST)="C" S DIFF=1
SITE W:$D(DIFF)&($Y) @IOF S DIFF=1 W:$D(^DD("SITE"))&(DHDR["S") !,"(",^("SITE"),")"
 I $D(DIC) I DHDR["F",@("$D("_DIC_"0))") W "  ",$P(^(0),U,1)," FILE"
 I $D(DUZ)#2,DHDR["U",$S($D(^VA(200,+DUZ,0)):1,1:$D(^DIC(3,+DUZ,0))) W "  USER: ",$P(^(0),U,1)," "
 W ?(DIXMM-(DHDR["T"*10)-($D(PG)*10)-8) I DHDR["T" D INT W %TIM W "  " K %TIM
 I '$D(DT) S X="T" D ^%DT S DT=Y
 W $E(DT,4,5),"/",DT#100,"/",$E(DT,2,3) I $D(PG) W "  PAGE ",PG S PG=PG+1
HDR F J=1:1 Q:'$D(DHDR(J))  W !?(DHDR["C"*(DIXMM-$L(DHDR(J))\2)),$E(DHDR(J),1,DIXMM)
 W ! Q:DHDR'["L"
LINE F %=1:1:DIXMM W "-"
 W ! Q
INT S %M=$P($H,",",2)\60
20 S %N=" AM" S:%M'<720 %M=%M-720,%N=" PM" S:%M<60 %M=%M+720
25 S %I=%M\600 S:'%I %I=" " S %TIM=%I_(%M\60#10)_":"_(%M#60\10)_(%M#10)_%N
30 K %M,%N,%I

DIXC
DIXC ;SFISC/GFT-DESCRIPTIVE STATS, CORRELATION MATRIX ;2/24/93  14:52 ;
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
D D DESC G DESCX
C D CORR G CORRX
 ;
SQR S Y=0 Q:X'>0  S Y=1+X/2
L S T=Y,Y=X/T+T/2 G L:Y<T
 K T Q
DLCOR S DJ=IO(0),U="^",SZ=0
 F SZT=1:1 S:$D(^DOSV(0,DJ,"CP",SZT)) SZ=SZT Q:'$D(^DOSV(0,DJ,0,SZT,"S"))  S DN(SZT)=$E($P(^DOSV(0,IO(0),"F",SZT),U,3),1,8)
 S SZT=SZT-1 Q
DESC ;CALCULATE THE DESCRIPTIVE STATISTICS.
 D DLCOR K DS F I=1:1:SZT I $D(^DOSV(0,DJ,0,I,"Q")) S X=^("Q")-((^("S")*^("S"))/^("N"))/(^("N")) D SQR S ^("D")=Y
 Q
DESCX ;PRINT DESCRIPTIVE STATS
 K DHDR S DHDR="77CUST",DHDR(1)="DESCRIPTIVE STATISTICS" D DHDR^DIX G Q:POP,QUE:$D(IO("Q"))
D1 W !!,?13,"N OF",?39,"STANDARD"
 W !,?13,"CASES",?25,"MEAN",?39,"DEVIATION",?54,"MINIMUM",?69,"MAXIMUM"
 F I=1:1:SZT D D10
 G KL
D10 W !,DN(I),?10 I $D(^DOSV(0,DJ,0,I,"N")) W $J(^("N"),6) W:^("N") $J(^("S")/^("N"),15,4)
 F X="D","L","H" W $S($D(^(X)):$J(^(X),15,4),1:$J("",15))
 Q
CORR ;CALCULATE THE CORRELATION MATRIX
 K ^UTILITY($J),ERR I $O(^DOSV(0,IO(0),1))'>0 W !!,"*****     AT LEAST TWO VARIABLES MUST BE DEFINED     *****" S ERR=1 Q
 D DLCOR ;F I=1:1:SZ I ^DOSV(0,IO(0),"BY",I,"H")=^("L") W $C(7),!,"CAN'T COMPUTE CORRELATION MATRIX--",DN(I+100)," IS SINGLE-VALUED" S ERR=1 G KL
 F I=2:1:SZ S N=^DOSV(0,DJ,0,I,"N"),S=^("S"),C=^DOSV(0,DJ,"CP",I,I) F J=1:1:I-1 I $D(^DOSV(0,DJ,"CP",I,J)) D C1
 G KL
C1 S X=N*C-(S*S)*(N*^DOSV(0,DJ,"CP",J,J))-(^DOSV(0,DJ,0,J,"S")*^("S"))
 D SQR S (^UTILITY($J,J,I),^UTILITY($J,I,J))=(N*^DOSV(0,DJ,"CP",I,J))-(S*^DOSV(0,DJ,0,J,"S"))/Y
 Q
CORRX ;OUTPUT THE CORRELATION MATRIX
 G:$D(ERR) KL K DHDR S DHDR="72TSU",DHDR(1)="CORRELATION MATRIX",DHDR(2)="" D DHDR^DIX G Q:POP
 F I=1:1:SZ S ^UTILITY($J,I,I)=1 I $D(^UTILITY($J,I,I)) W ?I*10-2,$J(DN(I),10)
 F I=1:1:SZ I $D(^UTILITY($J,I,I)) W !,DN(I) F J=1:1:I I $D(^UTILITY($J,I,J)) W ?J*10,$J(^UTILITY($J,I,J),8,4)
 W !!
KL W:$E(IOST)'="C"&($Y) @IOF I IO(0)'=IO D CLOSE^DIO4
Q U IO(0) K C,DHDR,I,II,J,JJ,N,POP,S,X,Y,Z,DJ,DN,SZ,SZT,DIFF
 Q
QUE ;
 F I="DHDR*","^DOSV(0,$I,","SZT","DN*" S ZTSAVE(I)=""
 S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIXC"
 D ^%ZTLOAD G KL
 ;
DQ S DJ=$I D DQ^DIX G D1