1:55 PM  11-JUL-96
Fileman 21 Patch 2 (cumulative thru seq 16)
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

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))

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

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

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

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

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

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"

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

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)

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

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)

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

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")

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

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

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

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

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

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
 ;

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

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

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)

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)

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

DICA
DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;3/31/95  13:36 ;
 ;;21.0;VA FileMan;**6,17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11765;5077499;
 
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
 K ^TMP("DIADD",$J)
INPUT 
 ; initialize input parameters & check
 N DIRULE S DIRULE="^TMP(""DICA"",$J)"
 N DIFDAO
 I $G(DIMSGA)'="" D
 . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
 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 $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

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

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

DICF
DICF ;SEA/TOAD-VA FileMan: Finder, Part 1 (Main) ;4/12/95  13:47 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11772;6981054;
 
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 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
 . I $G(DIMSGA)'="" D
 . . K @DIMSGA@("DIMSG"),@DIMSGA@("DIERR"),@DIMSGA@("DIHELP")
 . 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 '$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
 

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

DICF5
DICF5 ;SEA/TOAD-VA FileMan: Finder, Part 5 (Ptr Indexes) ;2/7/95  11:36 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11680;2906278;
 
PREPP(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 I DITYPE="P" D
 . 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
 . N DIFIELD,DIFILE,DIOUT
 . S DIPLIST("C")=0
 . S DIFILE=DINDEX(0,"FILE")
 . S DIFIELD=DINDEX(0,"FIELD")
 . S DIPFILE=0,DIOUT=0 F  D  Q:DIOUT
 . . S DIPFILE=$O(^DD(DIFILE,DIFIELD,"V","B",DIPFILE))
 . . I DIPFILE="" S DIOUT=1 Q
 . . D FIND^DICF(DIPFILE,"","","Mpv"_DIF,"","","","","",.DIPLIST,DIPLIST)
 . . S DISKIP=DIPLIST("C")=0&DISKIP
93 . I DIPVAL["." D PIECES(DIFILE,DIFIELD,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,DIFIELD,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(DIFILE,DIFIELD,DIFILEN,.DIFILES)
 K DIPLIST("LVA")
 N DIVALN S DIVALN=$P(DIPVAL,".",2,9999)
 S DIFILE="" F  S DIFILE=$O(DIFILES(DIFILE)) Q:DIFILE=""  D
 .  D FIND^DICF(DIFILE,"","","Mlpv"_DIFLAGS,DIVALN,"","","","",.DIPLIST,DIPLIST)
 S DISKIP=DIPLIST("C")=0&DISKIP
 Q

DICL
DICL ;SEA/TOAD-VA FileMan: Lookup: Lister ;6/13/95  15:05 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11806;4552973;
 
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
 
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(DIMSGA)'="" D
 . . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
 . 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 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
 

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
 ;

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

DICU1
DICU1 ;SEA/TOAD-VA FileMan: Lookup Tools, Get IDs ;7/19/95  17:39 ;
 ;;21.0;VA FileMan;**17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11831;5290202;
 
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("GET")="DIENTRY" Q
 . S DINDEX("FIELD")=.01
 . I '$D(@DIROOT@("B")) S DIFILE("NO B")=1 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

DIDU
DIDU ;SEA/TOAD-VA FileMan: DD Tools, Format ;3/9/95  15:34
 ;;21.0;VA FileMan;**6,17**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;11736;5942346;
 
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
INPUT 
 I $G(DINTERNL)="" Q ""
 S DIMSGA=$G(DIMSGA) I DIMSGA'="" D
 . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG")
 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")
 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")
 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

DIED
DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;8/15/95  13:48
 ;;21.0;VA FileMan;**1,13**;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) 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 I X'?.ANP S DDER=1 Q
 K DIR S DIR(0)="SMV^"_DU,DIR("V")=1
 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
 D ^DIR K DIR I 'DDER S %=Y(0),X=Y

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.?>

DIEZ1
DIEZ1 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;8/15/95  13:48
 ;;21.0;VA FileMan;**1,13**;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) 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 I X'?.ANP S DDER=1 Q 
 ;; N DIR S DIR(0)="SMV^"_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

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

DIFROMS5
DIFROMS5 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES OUT;07:13 AM  1 Feb 1995;
 ;;21.0;VA FileMan;**6**;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)
 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

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

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

DIFROMSU
DIFROMSU ;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY ;8/17/95  16:19 [ 05/16/96  5:05 PM ]
 ;;21.0;VA FileMan;**10**;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("B",IEN,"")) Q:IEN>0 $$ROOT(IEN)
 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...'

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

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

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

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

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

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

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

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'

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)

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

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

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

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

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"
 ;;

DIR1
DIR1 ;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;8/15/95  13:49
 ;;21.0;VA FileMan;**6,13**;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 S %E=0 D @%T I %A["X"!'%E!(X?.UNP) K %BU,%K Q
 S %M=X 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
 I $L(X)>245 S %E=1 Q
 I %T="S",$D(DIR("S"))#2 S DIC("S")=DIR("S")
 I %A["M" S %BU=$$UP^DILIBF(%B)
 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
 I %J="",$D(%BU),'%K 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
 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
 I '%E,$G(%M)]"" S X=%M K %M
 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

DITR
DITR ;SFISC/GFT-FIND FLDS TO XRF ;MAR 08, 1995@10:49
 ;;21.0;VA FileMan;**6**;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="" 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
NS I $G(DIFRFRV) D
 .S DIFRFRV1=$P($NA(@("DIFRFRV(D0,"_$P(DFR(DFL),DFR(1),2,255)_""""_DFN(DFL)_""")")),"DIFRFRV(",2,255),$E(DIFRFRV1,$L(DIFRFRV1))=""
 .Q:DIFRFRV1=$G(DIFRFRV2)
 .S DIFRFRV2=DIFRFRV1
 .Q:'$D(@DIFRSA@("FRV1",DIFRFILE,DIFRFRV1))
 .S @DIFRSA@("FRVL",DIFRFILE,DIFRFRV1)=$NA(@(DTO(DTL)_""""_DFN(DFL)_""")"))
 .Q
 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 S W=$E(B,2,9),B=$P(B,",",2) G NS:$E(X,+W,B)'?." "&DKP 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))_% G NS
 I DKP,$P(X,U,B)]"" G NS
P S $P(^(DTN(DTL)),U,B)=Y 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
 ;
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