DICQ1 ;SFISC/GFT,TKW - HELP FOR LOOKUPS ;01MAR2016
;;22.2;VA FileMan;**2,20**;Jan 05, 2016;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
EN ; Set up parameters for lister call, then display current entries.
I 'DIRECUR,'$D(DDS) D Z^DDSU
I DICNT>1,$D(DZ)#2 S DST=" " D:DZ["??"&'$D(DDS) %^DICQ S DST=$$EZBLD^DIALOG(8068) D %^DICQ
N DISCR S:$G(DIC("S"))]"" DISCR("S")=DIC("S")
I $D(DIC("V")) M DISCR("V")=DIC("V")
S %=$G(DIC("?PARAM",DIFILEI,"INDEX")) I %]"" D
. S (DIX,DIBEGIX)=%,DIX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"hl",.DIX) Q
I $O(DIC("?PARAM",DIFILEI,"PART",0)) S DIPART(1)="",%=0 D
. F S %=$O(DIC("?PARAM",DIFILEI,"PART",%)) Q:'% I '(%#1) S DIPART(%)=DIC("?PARAM",DIFILEI,"PART",%)
. S DIPART=DIPART(1) Q
N DIFLAGS,DIFIELDS,DIIENS S DIFLAGS="MPh"
I 'DIUPRITE,"PV"[$G(DIX(1,"TYPE")) D
. N DIFRPRT S DIFRPRT=DIFROM_$G(DIC("?PARAM",DIFILEI,"FROM",1))_$G(DIPART)
. Q:'$$CHKP^DICUIX1(.DIFILEI,.DIX,DDC,DIFRPRT,.DISCR,1)
. S DIFLAGS="MPQh" K DIFROM S DIFROM="" Q
I DIUPRITE S DID01=0,DIBEGIX="#"
S DIIENS=$S(DIC(0)["p":",",1:DIENS)
W S DIFIELDS="@;IX" D
.I 'DIUPRITE,DID01!(DIC(0)["S") K DID01 Q
.N EXT S EXT="$$EXT^DIC2("_DIFILEI_",.01,$P("_DIC_"Y,0),U))"
.I '$D(DDS)!'$D(DDSMOUSY) S DIC("DID01")="W "" "","_EXT Q
.S DIC("DID01")="W "" "" D WRITMOUS^DDSU("_EXT_")"
E1 K DDD S DD="",DIY=99,DDD=$S($D(DDS):1,1:5),(DIZ,DILN)=21
I $D(DDH)>10 D LIST^DDSU Q:$D(DDSQ)
I DIFROM]"" D S DIFROM(1)=DIFROM
. I +$P(DIFROM,"E")=DIFROM S DIFROM=DIFROM-.00000001 Q
. N M F %=$L(DIFROM):-1:1 S M=$A(DIFROM,%) I M>32 S DIFROM=$E(DIFROM,1,%-1)_$C(M-1)_$C(122) Q
. Q
I DIFLAGS'["Q" S %=$G(DIC("?PARAM",DIFILEI,"FROM",1)) I %]"" D
. S:DIFROM="" (DIFROM,DIFROM(1))=% S %=1
. F S %=$O(DIC("?PARAM",DIFILEI,"FROM",%)) Q:'% I '(%#1) S DIFROM(%)=DIC("?PARAM",DIFILEI,"FROM",%)
. Q
;
L ; List current entries in the file.
N DICQ
D LIST^DICL(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,DDC,.DIFROM,.DIPART,DIBEGIX,.DISCR,"","DICQ","",.DIC)
K DIC("DID01"),DICQ
D BK^DIEQ S:'$D(DDS) DDD=3 ;D LIST^DDSU ***
K DDH Q:$D(DDSQ)!($G(DTOUT))
D 0 Q
;
DSP(DINDEX,DICQ,DIC,DIFILE) ; Display entries from DICQ array
; note: this routine is called from the lister, DICLIX & DICL1.
N I,J,F,X,Y,DD,DDD,DIY,DILN,DIZ,DIMAP,DDH,DID01,DIQUIET,DIPGM,DST,DISPACE,DIERR,DP
S DIMAP=$G(DICQ(0,"MAP")),DDH=0,DST="",DIPGM="DICQ1",$P(DISPACE," ",10)=""
S:$G(DIC("DID01"))]"" DID01=DIC("DID01")
N DIKEYL,DIKEY I $O(DIFILE(DIFILE,"KEY",DIFILE,0)),DIC(0)'["S" M DIKEYL=DIFILE(DIFILE,"KEY",DIFILE)
I $D(DIC("W"))!($D(DID01))!($D(DIKEYL)) D ID
F I=0:0 S I=$O(DICQ(I)) Q:'I S X=$G(DICQ(I,0)) I X]"" D
. S DST=""
. I DINDEX="#" S DST=$P(X,U)_" " S:$L(DST)<7 DST=DST_$E(DISPACE,($L(DST)+1),7)
. I $D(DIKEYL) S DIKEY(+X)="" F J=0:0 S J=$O(DIKEYL(J)) Q:'J!$G(DIERR) F F=0:0 S F=$O(DIKEYL(J,F)) Q:'F!$G(DIERR) D
. . I (F=.01&($D(DID01))!(DINDEX("FLISTD")[("^"_F_"^"))) D Q
. . . S:DIKEY(+X)="" DIKEY(+X)=" " Q
. . S Y=$$GET1^DIQ(DIFILE,+X_DIFILE(DIFILE,"KEY","IEN"),F,"","","DIERR") Q:$G(DIERR)
. . I ($L(DIKEY(+X)))+($L(Y))+2>240 S DIERR=1 Q
. . S DIKEY(+X)=DIKEY(+X)_$P(" ^",U,DIKEY(+X)]"")_Y Q
. F J=2:1 Q:$P(DIMAP,U,J)="" S Y=$P(X,U,J) D:$P(DIMAP,U,J+1)]"" S:$L(DST_Y)<240 DST=DST_Y
. . S Y=Y_" "
. . I J=(DINDEX("#")+1) S Y=Y_" "
. . Q
. I DST]"" S Y=+X,DDH=DDH+1,DDH(DDH,Y)=DST_" "
. Q
S DD="",DIY=99,DDD=5,DP=DIFILE
I '$G(DIC("?N",DIFILE)) S (DIZ,DILN)=21
E S (DIZ,DILN)=999
D LIST^DDSU K DICQ
K DIERR,^TMP("DIERR",$J)
Q
;
ID ; Put code to display .01 field and Identifiers into DDH array.
S DIY="I $D("_DIC_"Y,0))" I $D(DID01) S DIY=DIY_" "_DID01_" "_DIY
I $D(DIKEYL) S:$D(DID01) DIY=DIY_" W "" """ S DIY=DIY_" W DIKEY(Y)"
I '$D(DIC("W")) S DDH("ID")=DIY Q
S DIY=DIY_" "
I $L(DIC("W"))+$L(DIY)<240 S DDH("ID")=DIY_DIC("W") Q
S DDH("ID")=DIY_"X DDH(""ID"",1)" S DDH("ID",1)=DIC("W") Q
;
WOV N DIC,Y,DI1X,DIY,DIYX,%,C,DINAME S DIC=DIGBL,Y=DIEN,DI1X=0
W1 F S DI1X=$O(^DD(DIFILEI,0,"ID",DI1X)) Q:DI1X="" S %=^(DI1X) D
. X "W "" "",$E("_DIGBL_DIEN_",0),0)",%
Q
;
0 ; If LAYGO allowed, display additional help.
K DDC,DIEQ,DIW,DS I DIC(0)'["L" D QQ Q
I $D(%Y)#2 S:%Y="??" DZ=%Y S:%Y?1P DZ="?"
S DDH=+$G(DDH) N A1,DIACCESS S DIACCESS=1
I $S($D(DLAYGO):DIFILEI\1-(DLAYGO\1),1:1),DUZ(0)'="@",'$D(^DD(DIFILEI,0,"UP")) D CHKACC ;p20 change DIFILEI
I '$G(DIACCESS) D RCR Q
10 ; Tell user that they may enter new entries to the file
I DZ?1."?" S DST=" " D DS^DIEQ S DST=$$EZBLD^DIALOG(8069,$P(DO,U)) D DS^DIEQ D:DZ="?" HP
D H
I DO(2)["S" S DST=$$EZBLD^DIALOG(8068)_" " D %^DICQ D
. N X,Y,I,A2,DST,DISETOC,DIMAXL,DIC
. ; Build list of selectable codes into DISETOC for online help.
. ; If set-of-codes field has a screen, execute it.
. S DIMAXL=0,DISETOC=""
. I $G(^DD(+DO(2),.01,12.1))]"" X ^(12.1)
. S X=$P(^DD(+DO(2),.01,0),U,3),I=+$P($P(^(0),U,2),"t",2) I X="",I S X=$$PROP4TYP^DIETLIBF("SET OF CODES",I)
. I '$D(DIC("S")) S DISETOC=X
. E F I=1:1 S Y=$P($P(X,";",I),":") Q:Y="" X DIC("S") I $T S DISETOC=DISETOC_$P(X,";",I)_";"
. K DIC("S")
. F X=1:1 S Y=$P($P(DISETOC,";",X),":") Q:Y="" S:$L(Y)>DIMAXL DIMAXL=$L(Y)
. S DIMAXL=DIMAXL+4
. F X=1:1 S Y=$P(DISETOC,";",X) Q:Y="" S A2="",$P(A2," ",DIMAXL-$L($P(Y,":")))=" ",DST=" "_$P(Y,":")_A2_$P(Y,":",2) D DS^DIEQ
. Q
I DO(2)["V" D
. N DG,DU,D
. S DU=+DO(2),D=.01 D V^DIEQ Q
;
RCR ; Recursive call to display entries on pointed-to file.
I DO(2)'["P"!($G(DZ(1))=0) D QQ Q
N %,D,DS,DIPTRIX S D=""
S DS=^DD(+DO(2),.01,0)
S DIPTRIX=$G(DIC("PTRIX",+DO(2),.01,+$P($P(DS,U,2),"P",2)))
M %=DIC("PTRIX"),%(1)=DIC("?N"),%(2)=DIC("?PARAM")
N DIC M DIC("PTRIX")=%,DIC("?N")=%(1),DIC("?PARAM")=%(2) K %
S DIC=U_$P(DS,U,3),DIC(0)=$E("L",$P(DS,U,2)'["'")
I $P(DS,U,2)["*" D
. N DILCV,DICP,DIPTRIX,DISAV0 S DISAV0=DIC(0)
. F DILCV=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S DICP=$F(DS,DILCV) I DICP D S DIC(0)=DISAV0
. . X $P($E(DS,1,DICP-$L(DILCV)-1),U,5,99) Q
. S D=$P($G(D),U) Q
S:DIPTRIX]"" D=$P(DIPTRIX,U) K DIPTRIX,DS
N DO,DIFILEI,DINDEX I D="" S D="B"
S DIRECUR=DIRECUR+1
D DQ^DICQ
QQ Q:$D(DDH)'>10
K DDD S DD="",DIY=99,DDD=$S($D(DDS):1,1:5),(DIZ,DILN)=21
S:$D(DDS) DDC=-1 D LIST^DDSU K DDC Q
;
HP N DG,X,%,DST
EGP S X=$$HELP^DIALOGZ(+DO(2),.01) D S X=$G(^DD(+DO(2),.01,12)) D ;**CCO/NI PLUS NEXT LINE WRITE HELP MESSAGE FOR .01 FIELD
.I X]"" F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<70 S DST=$P(X," ",1,%) D DS^DIEQ,P1 Q
Q
;
P1 I %'=$L(X," ") S DST=$P(X," ",%+1,99) D DS^DIEQ
Q
;
H ; Display eXecutable help and long description for .01 field.
N %,X,DIPGM S %=DIC,X=DZ,DIPGM="DICQ1" D
. N DIC,D,DP,DIFILEI,DINDEX,DZ S DZ=X
. S DIC=%,D=.01,DP=+DO(2) D H^DIEQ Q
Q
;
CHKACC ;Check file access
N A1,DIFILE,DIAC,% S DIFILE=+DO(2),DIAC="LAYGO",%=0 D ^DIAC
S:% DIACCESS=1 Q
;
;#8069 You may enter a new |filename|, if you wish
;#8068 Choose from
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICQ1 7147 printed Dec 13, 2024@02:46:34 Page 2
DICQ1 ;SFISC/GFT,TKW - HELP FOR LOOKUPS ;01MAR2016
+1 ;;22.2;VA FileMan;**2,20**;Jan 05, 2016;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
EN ; Set up parameters for lister call, then display current entries.
+1 IF 'DIRECUR
IF '$DATA(DDS)
DO Z^DDSU
+2 IF DICNT>1
IF $DATA(DZ)#2
SET DST=" "
if DZ["??"&'$DATA(DDS)
DO %^DICQ
SET DST=$$EZBLD^DIALOG(8068)
DO %^DICQ
+3 NEW DISCR
if $GET(DIC("S"))]""
SET DISCR("S")=DIC("S")
+4 IF $DATA(DIC("V"))
MERGE DISCR("V")=DIC("V")
+5 SET %=$GET(DIC("?PARAM",DIFILEI,"INDEX"))
IF %]""
Begin DoDot:1
+6 SET (DIX,DIBEGIX)=%
SET DIX("WAY")=1
DO INDEX^DICUIX(.DIFILEI,"hl",.DIX)
QUIT
End DoDot:1
+7 IF $ORDER(DIC("?PARAM",DIFILEI,"PART",0))
SET DIPART(1)=""
SET %=0
Begin DoDot:1
+8 FOR
SET %=$ORDER(DIC("?PARAM",DIFILEI,"PART",%))
if '%
QUIT
IF '(%#1)
SET DIPART(%)=DIC("?PARAM",DIFILEI,"PART",%)
+9 SET DIPART=DIPART(1)
QUIT
End DoDot:1
+10 NEW DIFLAGS,DIFIELDS,DIIENS
SET DIFLAGS="MPh"
+11 IF 'DIUPRITE
IF "PV"[$GET(DIX(1,"TYPE"))
Begin DoDot:1
+12 NEW DIFRPRT
SET DIFRPRT=DIFROM_$GET(DIC("?PARAM",DIFILEI,"FROM",1))_$GET(DIPART)
+13 if '$$CHKP^DICUIX1(.DIFILEI,.DIX,DDC,DIFRPRT,.DISCR,1)
QUIT
+14 SET DIFLAGS="MPQh"
KILL DIFROM
SET DIFROM=""
QUIT
End DoDot:1
+15 IF DIUPRITE
SET DID01=0
SET DIBEGIX="#"
+16 SET DIIENS=$SELECT(DIC(0)["p":",",1:DIENS)
W SET DIFIELDS="@;IX"
Begin DoDot:1
+1 IF 'DIUPRITE
IF DID01!(DIC(0)["S")
KILL DID01
QUIT
+2 NEW EXT
SET EXT="$$EXT^DIC2("_DIFILEI_",.01,$P("_DIC_"Y,0),U))"
+3 IF '$DATA(DDS)!'$DATA(DDSMOUSY)
SET DIC("DID01")="W "" "","_EXT
QUIT
+4 SET DIC("DID01")="W "" "" D WRITMOUS^DDSU("_EXT_")"
End DoDot:1
E1 KILL DDD
SET DD=""
SET DIY=99
SET DDD=$SELECT($DATA(DDS):1,1:5)
SET (DIZ,DILN)=21
+1 IF $DATA(DDH)>10
DO LIST^DDSU
if $DATA(DDSQ)
QUIT
+2 IF DIFROM]""
Begin DoDot:1
+3 IF +$PIECE(DIFROM,"E")=DIFROM
SET DIFROM=DIFROM-.00000001
QUIT
+4 NEW M
FOR %=$LENGTH(DIFROM):-1:1
SET M=$ASCII(DIFROM,%)
IF M>32
SET DIFROM=$EXTRACT(DIFROM,1,%-1)_$CHAR(M-1)_$CHAR(122)
QUIT
+5 QUIT
End DoDot:1
SET DIFROM(1)=DIFROM
+6 IF DIFLAGS'["Q"
SET %=$GET(DIC("?PARAM",DIFILEI,"FROM",1))
IF %]""
Begin DoDot:1
+7 if DIFROM=""
SET (DIFROM,DIFROM(1))=%
SET %=1
+8 FOR
SET %=$ORDER(DIC("?PARAM",DIFILEI,"FROM",%))
if '%
QUIT
IF '(%#1)
SET DIFROM(%)=DIC("?PARAM",DIFILEI,"FROM",%)
+9 QUIT
End DoDot:1
+10 ;
L ; List current entries in the file.
+1 NEW DICQ
+2 DO LIST^DICL(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,DDC,.DIFROM,.DIPART,DIBEGIX,.DISCR,"","DICQ","",.DIC)
+3 KILL DIC("DID01"),DICQ
+4 ;D LIST^DDSU ***
DO BK^DIEQ
if '$DATA(DDS)
SET DDD=3
+5 KILL DDH
if $DATA(DDSQ)!($GET(DTOUT))
QUIT
+6 DO 0
QUIT
+7 ;
DSP(DINDEX,DICQ,DIC,DIFILE) ; Display entries from DICQ array
+1 ; note: this routine is called from the lister, DICLIX & DICL1.
+2 NEW I,J,F,X,Y,DD,DDD,DIY,DILN,DIZ,DIMAP,DDH,DID01,DIQUIET,DIPGM,DST,DISPACE,DIERR,DP
+3 SET DIMAP=$GET(DICQ(0,"MAP"))
SET DDH=0
SET DST=""
SET DIPGM="DICQ1"
SET $PIECE(DISPACE," ",10)=""
+4 if $GET(DIC("DID01"))]""
SET DID01=DIC("DID01")
+5 NEW DIKEYL,DIKEY
IF $ORDER(DIFILE(DIFILE,"KEY",DIFILE,0))
IF DIC(0)'["S"
MERGE DIKEYL=DIFILE(DIFILE,"KEY",DIFILE)
+6 IF $DATA(DIC("W"))!($DATA(DID01))!($DATA(DIKEYL))
DO ID
+7 FOR I=0:0
SET I=$ORDER(DICQ(I))
if 'I
QUIT
SET X=$GET(DICQ(I,0))
IF X]""
Begin DoDot:1
+8 SET DST=""
+9 IF DINDEX="#"
SET DST=$PIECE(X,U)_" "
if $LENGTH(DST)<7
SET DST=DST_$EXTRACT(DISPACE,($LENGTH(DST)+1),7)
+10 IF $DATA(DIKEYL)
SET DIKEY(+X)=""
FOR J=0:0
SET J=$ORDER(DIKEYL(J))
if 'J!$GET(DIERR)
QUIT
FOR F=0:0
SET F=$ORDER(DIKEYL(J,F))
if 'F!$GET(DIERR)
QUIT
Begin DoDot:2
+11 IF (F=.01&($DATA(DID01))!(DINDEX("FLISTD")[("^"_F_"^")))
Begin DoDot:3
+12 if DIKEY(+X)=""
SET DIKEY(+X)=" "
QUIT
End DoDot:3
QUIT
+13 SET Y=$$GET1^DIQ(DIFILE,+X_DIFILE(DIFILE,"KEY","IEN"),F,"","","DIERR")
if $GET(DIERR)
QUIT
+14 IF ($LENGTH(DIKEY(+X)))+($LENGTH(Y))+2>240
SET DIERR=1
QUIT
+15 SET DIKEY(+X)=DIKEY(+X)_$PIECE(" ^",U,DIKEY(+X)]"")_Y
QUIT
End DoDot:2
+16 FOR J=2:1
if $PIECE(DIMAP,U,J)=""
QUIT
SET Y=$PIECE(X,U,J)
if $PIECE(DIMAP,U,J+1)]""
Begin DoDot:2
+17 SET Y=Y_" "
+18 IF J=(DINDEX("#")+1)
SET Y=Y_" "
+19 QUIT
End DoDot:2
if $LENGTH(DST_Y)<240
SET DST=DST_Y
+20 IF DST]""
SET Y=+X
SET DDH=DDH+1
SET DDH(DDH,Y)=DST_" "
+21 QUIT
End DoDot:1
+22 SET DD=""
SET DIY=99
SET DDD=5
SET DP=DIFILE
+23 IF '$GET(DIC("?N",DIFILE))
SET (DIZ,DILN)=21
+24 IF '$TEST
SET (DIZ,DILN)=999
+25 DO LIST^DDSU
KILL DICQ
+26 KILL DIERR,^TMP("DIERR",$JOB)
+27 QUIT
+28 ;
ID ; Put code to display .01 field and Identifiers into DDH array.
+1 SET DIY="I $D("_DIC_"Y,0))"
IF $DATA(DID01)
SET DIY=DIY_" "_DID01_" "_DIY
+2 IF $DATA(DIKEYL)
if $DATA(DID01)
SET DIY=DIY_" W "" """
SET DIY=DIY_" W DIKEY(Y)"
+3 IF '$DATA(DIC("W"))
SET DDH("ID")=DIY
QUIT
+4 SET DIY=DIY_" "
+5 IF $LENGTH(DIC("W"))+$LENGTH(DIY)<240
SET DDH("ID")=DIY_DIC("W")
QUIT
+6 SET DDH("ID")=DIY_"X DDH(""ID"",1)"
SET DDH("ID",1)=DIC("W")
QUIT
+7 ;
WOV NEW DIC,Y,DI1X,DIY,DIYX,%,C,DINAME
SET DIC=DIGBL
SET Y=DIEN
SET DI1X=0
W1 FOR
SET DI1X=$ORDER(^DD(DIFILEI,0,"ID",DI1X))
if DI1X=""
QUIT
SET %=^(DI1X)
Begin DoDot:1
+1 XECUTE "W "" "",$E("_DIGBL_DIEN_",0),0)"
XECUTE %
End DoDot:1
+2 QUIT
+3 ;
0 ; If LAYGO allowed, display additional help.
+1 KILL DDC,DIEQ,DIW,DS
IF DIC(0)'["L"
DO QQ
QUIT
+2 IF $DATA(%Y)#2
if %Y="??"
SET DZ=%Y
if %Y?1P
SET DZ="?"
+3 SET DDH=+$GET(DDH)
NEW A1,DIACCESS
SET DIACCESS=1
+4 ;p20 change DIFILEI
IF $SELECT($DATA(DLAYGO):DIFILEI\1-(DLAYGO\1),1:1)
IF DUZ(0)'="@"
IF '$DATA(^DD(DIFILEI,0,"UP"))
DO CHKACC
+5 IF '$GET(DIACCESS)
DO RCR
QUIT
10 ; Tell user that they may enter new entries to the file
+1 IF DZ?1."?"
SET DST=" "
DO DS^DIEQ
SET DST=$$EZBLD^DIALOG(8069,$PIECE(DO,U))
DO DS^DIEQ
if DZ="?"
DO HP
+2 DO H
+3 IF DO(2)["S"
SET DST=$$EZBLD^DIALOG(8068)_" "
DO %^DICQ
Begin DoDot:1
+4 NEW X,Y,I,A2,DST,DISETOC,DIMAXL,DIC
+5 ; Build list of selectable codes into DISETOC for online help.
+6 ; If set-of-codes field has a screen, execute it.
+7 SET DIMAXL=0
SET DISETOC=""
+8 IF $GET(^DD(+DO(2),.01,12.1))]""
XECUTE ^(12.1)
+9 SET X=$PIECE(^DD(+DO(2),.01,0),U,3)
SET I=+$PIECE($PIECE(^(0),U,2),"t",2)
IF X=""
IF I
SET X=$$PROP4TYP^DIETLIBF("SET OF CODES",I)
+10 IF '$DATA(DIC("S"))
SET DISETOC=X
+11 IF '$TEST
FOR I=1:1
SET Y=$PIECE($PIECE(X,";",I),":")
if Y=""
QUIT
XECUTE DIC("S")
IF $TEST
SET DISETOC=DISETOC_$PIECE(X,";",I)_";"
+12 KILL DIC("S")
+13 FOR X=1:1
SET Y=$PIECE($PIECE(DISETOC,";",X),":")
if Y=""
QUIT
if $LENGTH(Y)>DIMAXL
SET DIMAXL=$LENGTH(Y)
+14 SET DIMAXL=DIMAXL+4
+15 FOR X=1:1
SET Y=$PIECE(DISETOC,";",X)
if Y=""
QUIT
SET A2=""
SET $PIECE(A2," ",DIMAXL-$LENGTH($PIECE(Y,":")))=" "
SET DST=" "_$PIECE(Y,":")_A2_$PIECE(Y,":",2)
DO DS^DIEQ
+16 QUIT
End DoDot:1
+17 IF DO(2)["V"
Begin DoDot:1
+18 NEW DG,DU,D
+19 SET DU=+DO(2)
SET D=.01
DO V^DIEQ
QUIT
End DoDot:1
+20 ;
RCR ; Recursive call to display entries on pointed-to file.
+1 IF DO(2)'["P"!($GET(DZ(1))=0)
DO QQ
QUIT
+2 NEW %,D,DS,DIPTRIX
SET D=""
+3 SET DS=^DD(+DO(2),.01,0)
+4 SET DIPTRIX=$GET(DIC("PTRIX",+DO(2),.01,+$PIECE($PIECE(DS,U,2),"P",2)))
+5 MERGE %=DIC("PTRIX"),%(1)=DIC("?N"),%(2)=DIC("?PARAM")
+6 NEW DIC
MERGE DIC("PTRIX")=%,DIC("?N")=%(1),DIC("?PARAM")=%(2)
KILL %
+7 SET DIC=U_$PIECE(DS,U,3)
SET DIC(0)=$EXTRACT("L",$PIECE(DS,U,2)'["'")
+8 IF $PIECE(DS,U,2)["*"
Begin DoDot:1
+9 NEW DILCV,DICP,DIPTRIX,DISAV0
SET DISAV0=DIC(0)
+10 FOR DILCV=" D ^DIC"," D IX^DIC"," D MIX^DIC1"
SET DICP=$FIND(DS,DILCV)
IF DICP
Begin DoDot:2
+11 XECUTE $PIECE($EXTRACT(DS,1,DICP-$LENGTH(DILCV)-1),U,5,99)
QUIT
End DoDot:2
SET DIC(0)=DISAV0
+12 SET D=$PIECE($GET(D),U)
QUIT
End DoDot:1
+13 if DIPTRIX]""
SET D=$PIECE(DIPTRIX,U)
KILL DIPTRIX,DS
+14 NEW DO,DIFILEI,DINDEX
IF D=""
SET D="B"
+15 SET DIRECUR=DIRECUR+1
+16 DO DQ^DICQ
QQ if $DATA(DDH)'>10
QUIT
+1 KILL DDD
SET DD=""
SET DIY=99
SET DDD=$SELECT($DATA(DDS):1,1:5)
SET (DIZ,DILN)=21
+2 if $DATA(DDS)
SET DDC=-1
DO LIST^DDSU
KILL DDC
QUIT
+3 ;
HP NEW DG,X,%,DST
EGP ;**CCO/NI PLUS NEXT LINE WRITE HELP MESSAGE FOR .01 FIELD
SET X=$$HELP^DIALOGZ(+DO(2),.01)
Begin DoDot:1
+1 IF X]""
FOR %=$LENGTH(X," "):-1:1
IF $LENGTH($PIECE(X," ",1,%))<70
SET DST=$PIECE(X," ",1,%)
DO DS^DIEQ
DO P1
QUIT
End DoDot:1
SET X=$GET(^DD(+DO(2),.01,12))
Begin DoDot:1
End DoDot:1
+2 QUIT
+3 ;
P1 IF %'=$LENGTH(X," ")
SET DST=$PIECE(X," ",%+1,99)
DO DS^DIEQ
+1 QUIT
+2 ;
H ; Display eXecutable help and long description for .01 field.
+1 NEW %,X,DIPGM
SET %=DIC
SET X=DZ
SET DIPGM="DICQ1"
Begin DoDot:1
+2 NEW DIC,D,DP,DIFILEI,DINDEX,DZ
SET DZ=X
+3 SET DIC=%
SET D=.01
SET DP=+DO(2)
DO H^DIEQ
QUIT
End DoDot:1
+4 QUIT
+5 ;
CHKACC ;Check file access
+1 NEW A1,DIFILE,DIAC,%
SET DIFILE=+DO(2)
SET DIAC="LAYGO"
SET %=0
DO ^DIAC
+2 if %
SET DIACCESS=1
QUIT
+3 ;
+4 ;#8069 You may enter a new |filename|, if you wish
+5 ;#8068 Choose from
