DICQ ;SFISC/XAK,TKW-HELP FOR LOOKUPS ;26DEC2005
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
S DZ=X D:DIC(0)]"" DQ
I '$D(DDS),$G(DDH) D ^DDSU
S:$D(DZ) X=DZ K DZ,DDH,DIZ,DDD I $D(DTOUT) S Y=-1 D Q^DIC2 Q
D A^DIC Q
;
DQ ; Main entry point for displaying online ^DIC help (list of current
; entries in a file.
N %,%Y,X,Y,DD,DDC,DDD,DS,DID01,DICNT,DIDONE,DIFROM,DIPART,DIW,DIX,DIY,DIZ,DIUPRITE,DST,DIBEGSUB,DIBEGIX
I $D(DZ)[0 N DZ S DZ=""
S DDC=$S($D(DDS):7,1:$G(IOSL,24)-9) ;USE SCREEN LENGTH
N:'$D(DDH) DDH S DDH=+$G(DDH)
S DIBEGIX=D
I $D(DIRECUR)[0 N DIRECUR S DIRECUR=0
I '$D(DO(2)) N DO D GETFA^DIC1(.DIC,.DO)
I DO="0^-1" K DO S DST=" Pointed-to File does not exist!" D % Q
S DICNT=$P(DO,U,4),DIY=DO D DIY
NUMEGP S X=$S($D(^DD(+DO(2),.001,0)):$$LABEL^DIALOGZ(+DO(2),.001),DIC(0)["N":$$EZBLD^DIALOG(7099),1:""),DIUPRITE=X]"" ;**CCO/NI "NUMBER"
S DIW=^DD(+DO(2),.01,0),DIW=$P(DIW,U,2,3)
G:$D(^DD(+DO(2),0,"QUES")) @^("QUES")
I DIUPRITE S DS=.001 D DS
DQ1 I $G(DIFILEI),$G(DINDEX)]"" M DIX=DINDEX
E N DIFILEI,DIENS K % M %=DA N DA M DA=% K % D
. D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS)
. S DIX=$G(D),DIX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"hl",.DIX)
. Q
S DIBEGSUB=DIX("#")
I DIFILEI="" D % Q
I $D(DIC("?N",DIFILEI)) S DDC=DIC("?N",DIFILEI)
S DIFROM=""
N DISAVIX M DISAVIX=DIX
D IX K DISAVIX
I 'DICNT D 0 Q
S DIDONE=0 I DZ'="??" D I DIDONE D 0 Q
. D DSPFLD Q:DICNT<11
. N DIOUT S DIOUT=0 F D ASKCUR Q:DIOUT
. Q
D EN^DICQ1
Q
;
IX N DD,DIF,DIFIL,DIFLD,DIFORCE,DIEND,DITMP,I,P,F,X,%
S (DD,%)="",DID01=0,DIF="h"_$P("M^",U,DIC(0)["M")
S DIFORCE=$S($D(DID):1,1:0),DIFORCE(0)=$S($D(DID):DID,1:"*"),DIFORCE(1)=1
F D Q:DIX=""!(DIC(0)'["M")
. S DIEND=$S(DIX=DIBEGIX:DIX("#"),1:1)
. S (P,DS)="" F I=1:1:DIEND D
. . S DIFIL=$G(DIX(I,"FILE")),DIFLD=$G(DIX(I,"FIELD"))
. . I DIFIL,DIFLD Q:$D(DITMP(DIFIL,DIFLD)) S DITMP(DIFIL,DIFLD)=""
. . I DIX=DIBEGIX D
. . . I DIFIL=DIFILEI,DIFLD=.01,DIX("FLISTD")[("^"_.01_"^") S DID01=1
. . . S DS=.002 Q
. . E S X=DIFLD S:DIFILEI'=DIFIL X=DIFIL_" "_DIFLD S:DS]"" DS=DS_"^" S DS=DS_X
. . S X=$G(DIX(I,"PROMPT"))
FIELDNM . . I $D(^DD(+DIFIL,+DIFLD,0))#2 S X=$$LABEL^DIALOGZ(+DIFIL,+DIFLD) ;**CCO/NI NAME OF LOOKUP FIELD
. . I I=1 S %=DIX(1,"TYPE")
. . Q:X="" I DIX("#")=1,X=$G(DS(.002)) Q
. . I $L(X)+$L(P)'>70 S P=P_$P(" & ^",U,P]"")_X Q
. . S:P'["..." P=P_"..." Q
. I P]"",DS]"" S X=P D DS
. I @("$D("_DIC_"DIX))>9!$D(DF)"),DD="" S DD=DIX,DIW=% S:'DICNT DICNT=2 S:'$D(^(DD)) DICNT=0,DIUPRITE=0
. I DIC(0)'["M" S DIX="" Q
. D NXTINDX^DICF2(.DIX,.DIFORCE,.DIFILEI,DIF,"","*") Q:DIX=""
. D INDEX^DICUIX(.DIFILEI,"hql",.DIX) Q
K DIX
I DIBEGIX=DD M DIX=DISAVIX
E S (DIBEGIX,DIX)=DD I DIX]"" S DIX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"hl",.DIX)
I DD="" S DIUPRITE=1 I $O(^DD(DIFILEI,0,"IX","AZ"))]""!($O(^DD("IX","BB",DIFILEI,"AZ"))]"") S DICNT=0
S:DZ["BAD" DICNT=0
Q
;
DSPFLD ; Display list of lookup fields
N X S DST=$$EZBLD^DIALOG(8063,$P(DO,U)),DS=0
F X=1:1 S DS=$O(DS(DS)) Q:DS="" D
. S:X>1!$G(DS(0)) DST=DST_$$EZBLD^DIALOG(8067)
. D:$L(DST)+$L(DS(DS))>70 N S DST=DST_" "_DS(DS) Q
K DS S DST=DST_$E(":",DICNT) D %
Q
;
ASKCUR ; Ask if user wants to see existing entries
N A1 S DDH=DDH+1,A1=0_U_$$EZBLD^DIALOG(8064)
I DO(2)'["s",'$D(DIC("S")),'$D(DIC("V")),'$D(DF),'$D(DIC("?PARAM",DIFILEI)) S A1=A1_$$EZBLD^DIALOG(8065,DICNT)
S DDH(DDH,"Q")=A1_$$EZBLD^DIALOG(8066,$P(DO,U))
S:$D(DDS) DDD=1 D ^DDSU
I '$D(DDS),$D(DTOUT) S (DIOUT,DIDONE)=1 Q
I $D(DDS) S %=1 I $D(DDSQ) S (DIOUT,DIDONE)=1 Q
; Process answer to question about seeing existing entries.
S A1="T",DDH=+$G(DDH)
S:%=1 %Y=1
I %Y'="??" D
. N F S F=$E(%Y,2,99) I $E(%Y)="^",F]"" S DIFROM=F
. S %Y=F Q
S:%=2&(DIC(0)["L") DZ=""
I (%#2)=0!(%<0&(%Y="")) S (DIOUT,DIDONE)=1 Q
I DIFROM="" S DIOUT=1 Q
S DIUPRITE=$S(+$P(DIFROM,"E")=DIFROM:1,DIBEGIX]"":0,1:DIUPRITE)
I +$P(DIFROM,"E")=DIFROM S DIOUT=1 Q
Q:DIBEGIX="" I $P(DIW,U,1)'["D" S DIOUT=1 Q
N %DT,Y S X=DIFROM,%DT="T" D ^%DT S DIFROM=Y,DIUPRITE=0
I DIFROM<0 S DST=$C(7) D % Q
S DIOUT=1 Q
;
DSPHLP(DIC,DIFILE,DINDEX,DZ,DINOKILL) ; Display online help for lookups (^DIC)
N D S D=DINDEX
I $D(DIBTDH) K DIBTDH Q
S:$D(DDSXEC) DIBTDH=1 ; Set only if there is eXecutable Help to prevent repeated '??' display from AST^DIEQ
I DIC(0)]"" D DQ Q:$G(DINOKILL)
I '$D(DDS),$G(DDH) D ^DDSU
I $D(DTOUT) S Y=-1 D Q^DIC2 Q
D A^DIC Q
;
N D % S DST=" " Q
;
% ;CALLED FROM ^DICQ1
S DDH=$G(DDH)+1,DDH(DDH,"T")=DST K DST Q
;
0 Q:$D(DTOUT)!(DIC(0)'["L") K DIW,DIUPRITE S:$D(DDS) DDD=1 D 0^DICQ1 Q
;
DIY S DIY=$P(^DD(+$P(DIY,U,2),.01,0),"$L(X)>",2),DIY=$S(DIY:DIY,1:30)+7 Q
;
SOUNDEX G DQ1
;
DS S:DO'[X DS(DS)=X I DO[X,$G(DZ)'["??" S DS(0)=1
Q
;
;
;
;#8063 Answer with |Filename|
;#8064 Do you want the entire
;#8065 |Number of entries| Entry
;#8066 |Filename| List
;#8067 , or
;#8068 Choose from ; couldn't find a reference SO 8/11/00
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICQ 5266 printed Nov 22, 2024@17:56:28 Page 2
DICQ ;SFISC/XAK,TKW-HELP FOR LOOKUPS ;26DEC2005
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
+7 SET DZ=X
if DIC(0)]""
DO DQ
+8 IF '$DATA(DDS)
IF $GET(DDH)
DO ^DDSU
+9 if $DATA(DZ)
SET X=DZ
KILL DZ,DDH,DIZ,DDD
IF $DATA(DTOUT)
SET Y=-1
DO Q^DIC2
QUIT
+10 DO A^DIC
QUIT
+11 ;
DQ ; Main entry point for displaying online ^DIC help (list of current
+1 ; entries in a file.
+2 NEW %,%Y,X,Y,DD,DDC,DDD,DS,DID01,DICNT,DIDONE,DIFROM,DIPART,DIW,DIX,DIY,DIZ,DIUPRITE,DST,DIBEGSUB,DIBEGIX
+3 IF $DATA(DZ)[0
NEW DZ
SET DZ=""
+4 ;USE SCREEN LENGTH
SET DDC=$SELECT($DATA(DDS):7,1:$GET(IOSL,24)-9)
+5 if '$DATA(DDH)
NEW DDH
SET DDH=+$GET(DDH)
+6 SET DIBEGIX=D
+7 IF $DATA(DIRECUR)[0
NEW DIRECUR
SET DIRECUR=0
+8 IF '$DATA(DO(2))
NEW DO
DO GETFA^DIC1(.DIC,.DO)
+9 IF DO="0^-1"
KILL DO
SET DST=" Pointed-to File does not exist!"
DO %
QUIT
+10 SET DICNT=$PIECE(DO,U,4)
SET DIY=DO
DO DIY
NUMEGP ;**CCO/NI "NUMBER"
SET X=$SELECT($DATA(^DD(+DO(2),.001,0)):$$LABEL^DIALOGZ(+DO(2),.001),DIC(0)["N":$$EZBLD^DIALOG(7099),1:"")
SET DIUPRITE=X]""
+1 SET DIW=^DD(+DO(2),.01,0)
SET DIW=$PIECE(DIW,U,2,3)
+2 if $DATA(^DD(+DO(2),0,"QUES"))
GOTO @^("QUES")
+3 IF DIUPRITE
SET DS=.001
DO DS
DQ1 IF $GET(DIFILEI)
IF $GET(DINDEX)]""
MERGE DIX=DINDEX
+1 IF '$TEST
NEW DIFILEI,DIENS
KILL %
MERGE %=DA
NEW DA
MERGE DA=%
KILL %
Begin DoDot:1
+2 DO GETFILE^DIC0(.DIC,.DIFILEI,.DIENS)
+3 SET DIX=$GET(D)
SET DIX("WAY")=1
DO INDEX^DICUIX(.DIFILEI,"hl",.DIX)
+4 QUIT
End DoDot:1
+5 SET DIBEGSUB=DIX("#")
+6 IF DIFILEI=""
DO %
QUIT
+7 IF $DATA(DIC("?N",DIFILEI))
SET DDC=DIC("?N",DIFILEI)
+8 SET DIFROM=""
+9 NEW DISAVIX
MERGE DISAVIX=DIX
+10 DO IX
KILL DISAVIX
+11 IF 'DICNT
DO 0
QUIT
+12 SET DIDONE=0
IF DZ'="??"
Begin DoDot:1
+13 DO DSPFLD
if DICNT<11
QUIT
+14 NEW DIOUT
SET DIOUT=0
FOR
DO ASKCUR
if DIOUT
QUIT
+15 QUIT
End DoDot:1
IF DIDONE
DO 0
QUIT
+16 DO EN^DICQ1
+17 QUIT
+18 ;
IX NEW DD,DIF,DIFIL,DIFLD,DIFORCE,DIEND,DITMP,I,P,F,X,%
+1 SET (DD,%)=""
SET DID01=0
SET DIF="h"_$PIECE("M^",U,DIC(0)["M")
+2 SET DIFORCE=$SELECT($DATA(DID):1,1:0)
SET DIFORCE(0)=$SELECT($DATA(DID):DID,1:"*")
SET DIFORCE(1)=1
+3 FOR
Begin DoDot:1
+4 SET DIEND=$SELECT(DIX=DIBEGIX:DIX("#"),1:1)
+5 SET (P,DS)=""
FOR I=1:1:DIEND
Begin DoDot:2
+6 SET DIFIL=$GET(DIX(I,"FILE"))
SET DIFLD=$GET(DIX(I,"FIELD"))
+7 IF DIFIL
IF DIFLD
if $DATA(DITMP(DIFIL,DIFLD))
QUIT
SET DITMP(DIFIL,DIFLD)=""
+8 IF DIX=DIBEGIX
Begin DoDot:3
+9 IF DIFIL=DIFILEI
IF DIFLD=.01
IF DIX("FLISTD")[("^"_.01_"^")
SET DID01=1
+10 SET DS=.002
QUIT
End DoDot:3
+11 IF '$TEST
SET X=DIFLD
if DIFILEI'=DIFIL
SET X=DIFIL_" "_DIFLD
if DS]""
SET DS=DS_"^"
SET DS=DS_X
+12 SET X=$GET(DIX(I,"PROMPT"))
FIELDNM ;**CCO/NI NAME OF LOOKUP FIELD
IF $DATA(^DD(+DIFIL,+DIFLD,0))#2
SET X=$$LABEL^DIALOGZ(+DIFIL,+DIFLD)
+1 IF I=1
SET %=DIX(1,"TYPE")
+2 if X=""
QUIT
IF DIX("#")=1
IF X=$GET(DS(.002))
QUIT
+3 IF $LENGTH(X)+$LENGTH(P)'>70
SET P=P_$PIECE(" & ^",U,P]"")_X
QUIT
+4 if P'["..."
SET P=P_"..."
QUIT
End DoDot:2
+5 IF P]""
IF DS]""
SET X=P
DO DS
+6 IF @("$D("_DIC_"DIX))>9!$D(DF)")
IF DD=""
SET DD=DIX
SET DIW=%
if 'DICNT
SET DICNT=2
if '$DATA(^(DD))
SET DICNT=0
SET DIUPRITE=0
+7 IF DIC(0)'["M"
SET DIX=""
QUIT
+8 DO NXTINDX^DICF2(.DIX,.DIFORCE,.DIFILEI,DIF,"","*")
if DIX=""
QUIT
+9 DO INDEX^DICUIX(.DIFILEI,"hql",.DIX)
QUIT
End DoDot:1
if DIX=""!(DIC(0)'["M")
QUIT
+10 KILL DIX
+11 IF DIBEGIX=DD
MERGE DIX=DISAVIX
+12 IF '$TEST
SET (DIBEGIX,DIX)=DD
IF DIX]""
SET DIX("WAY")=1
DO INDEX^DICUIX(.DIFILEI,"hl",.DIX)
+13 IF DD=""
SET DIUPRITE=1
IF $ORDER(^DD(DIFILEI,0,"IX","AZ"))]""!($ORDER(^DD("IX","BB",DIFILEI,"AZ"))]"")
SET DICNT=0
+14 if DZ["BAD"
SET DICNT=0
+15 QUIT
+16 ;
DSPFLD ; Display list of lookup fields
+1 NEW X
SET DST=$$EZBLD^DIALOG(8063,$PIECE(DO,U))
SET DS=0
+2 FOR X=1:1
SET DS=$ORDER(DS(DS))
if DS=""
QUIT
Begin DoDot:1
+3 if X>1!$GET(DS(0))
SET DST=DST_$$EZBLD^DIALOG(8067)
+4 if $LENGTH(DST)+$LENGTH(DS(DS))>70
DO N
SET DST=DST_" "_DS(DS)
QUIT
End DoDot:1
+5 KILL DS
SET DST=DST_$EXTRACT(":",DICNT)
DO %
+6 QUIT
+7 ;
ASKCUR ; Ask if user wants to see existing entries
+1 NEW A1
SET DDH=DDH+1
SET A1=0_U_$$EZBLD^DIALOG(8064)
+2 IF DO(2)'["s"
IF '$DATA(DIC("S"))
IF '$DATA(DIC("V"))
IF '$DATA(DF)
IF '$DATA(DIC("?PARAM",DIFILEI))
SET A1=A1_$$EZBLD^DIALOG(8065,DICNT)
+3 SET DDH(DDH,"Q")=A1_$$EZBLD^DIALOG(8066,$PIECE(DO,U))
+4 if $DATA(DDS)
SET DDD=1
DO ^DDSU
+5 IF '$DATA(DDS)
IF $DATA(DTOUT)
SET (DIOUT,DIDONE)=1
QUIT
+6 IF $DATA(DDS)
SET %=1
IF $DATA(DDSQ)
SET (DIOUT,DIDONE)=1
QUIT
+7 ; Process answer to question about seeing existing entries.
+8 SET A1="T"
SET DDH=+$GET(DDH)
+9 if %=1
SET %Y=1
+10 IF %Y'="??"
Begin DoDot:1
+11 NEW F
SET F=$EXTRACT(%Y,2,99)
IF $EXTRACT(%Y)="^"
IF F]""
SET DIFROM=F
+12 SET %Y=F
QUIT
End DoDot:1
+13 if %=2&(DIC(0)["L")
SET DZ=""
+14 IF (%#2)=0!(%<0&(%Y=""))
SET (DIOUT,DIDONE)=1
QUIT
+15 IF DIFROM=""
SET DIOUT=1
QUIT
+16 SET DIUPRITE=$SELECT(+$PIECE(DIFROM,"E")=DIFROM:1,DIBEGIX]"":0,1:DIUPRITE)
+17 IF +$PIECE(DIFROM,"E")=DIFROM
SET DIOUT=1
QUIT
+18 if DIBEGIX=""
QUIT
IF $PIECE(DIW,U,1)'["D"
SET DIOUT=1
QUIT
+19 NEW %DT,Y
SET X=DIFROM
SET %DT="T"
DO ^%DT
SET DIFROM=Y
SET DIUPRITE=0
+20 IF DIFROM<0
SET DST=$CHAR(7)
DO %
QUIT
+21 SET DIOUT=1
QUIT
+22 ;
DSPHLP(DIC,DIFILE,DINDEX,DZ,DINOKILL) ; Display online help for lookups (^DIC)
+1 NEW D
SET D=DINDEX
+2 IF $DATA(DIBTDH)
KILL DIBTDH
QUIT
+3 ; Set only if there is eXecutable Help to prevent repeated '??' display from AST^DIEQ
if $DATA(DDSXEC)
SET DIBTDH=1
+4 IF DIC(0)]""
DO DQ
if $GET(DINOKILL)
QUIT
+5 IF '$DATA(DDS)
IF $GET(DDH)
DO ^DDSU
+6 IF $DATA(DTOUT)
SET Y=-1
DO Q^DIC2
QUIT
+7 DO A^DIC
QUIT
+8 ;
N DO %
SET DST=" "
QUIT
+1 ;
% ;CALLED FROM ^DICQ1
+1 SET DDH=$GET(DDH)+1
SET DDH(DDH,"T")=DST
KILL DST
QUIT
+2 ;
0 if $DATA(DTOUT)!(DIC(0)'["L")
QUIT
KILL DIW,DIUPRITE
if $DATA(DDS)
SET DDD=1
DO 0^DICQ1
QUIT
+1 ;
DIY SET DIY=$PIECE(^DD(+$PIECE(DIY,U,2),.01,0),"$L(X)>",2)
SET DIY=$SELECT(DIY:DIY,1:30)+7
QUIT
+1 ;
SOUNDEX GOTO DQ1
+1 ;
DS if DO'[X
SET DS(DS)=X
IF DO[X
IF $GET(DZ)'["??"
SET DS(0)=1
+1 QUIT
+2 ;
+3 ;
+4 ;
+5 ;#8063 Answer with |Filename|
+6 ;#8064 Do you want the entire
+7 ;#8065 |Number of entries| Entry
+8 ;#8066 |Filename| List
+9 ;#8067 , or
+10 ;#8068 Choose from ; couldn't find a reference SO 8/11/00
