- 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 Jan 18, 2025@03:47:33 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