DIC11 ;SFISC/TKW-PROMPT USER FOR LOOKUP VALUES ;05:33 PM 11 Aug 2002
;;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.
;
PROMPT N DIOUT S (DIVAL(0),DIOUT)=0
F DISUB=1:1:DINDEX("#") D PR1 Q:DIOUT
S X=$G(DIVAL(1))
I DINDEX("#")>1 M X=DIVAL D K X(0) ; W:$O(DIVAL(1)) !
. I X?1"^"1.E K X S X=$G(DIVAL(1)) Q
Q
;
PR1 S DIY=DIPRMT(DISUB),DIVAL(DISUB)="" N X
I $G(DIY(DISUB))]"" S DIY=DIY_$S($D(DIY(DISUB,"EXT")):DIY(DISUB,"EXT"),1:DIY(DISUB))_"// "
W DIY R X:$S($G(DTIME):DTIME,1:300)
I '$T S (DIOUT,DTOUT)=1 W $C(7) K DIVAL S DIVAL(0)=0 Q
I X'?.ANP D:DIC(0)["Q" S DISUB=DISUB-1 Q
. W $C(7)," ",$$EZBLD^DIALOG(204),! Q
I X?1.N.1"."1.N,($L($P(X,"."))>25!($L($P(X,".",2))>24)) D:DIC(0)["Q" S DISUB=DISUB-1 Q
. W $C(7)," ",$$EZBLD^DIALOG(208),! Q
I X="^"!($E(X)="^"&(DISUB>1)) S (DIOUT,DUOUT)=1 K DIVAL S DIVAL(0)=0,DIVAL(1)="^" Q
I $L(X)>250 D:DIC(0)["Q" S DISUB=DISUB-1 Q
. W $C(7)," ",$$EZBLD^DIALOG(209),! Q
I X?1."?" K DIVAL S DIVAL(1)=$E(X,1,2),DIVAL(0)=0,DIOUT=1 Q
I (X?1"`".NP)!(X=" ") K DIVAL S DIVAL(1)=X,(DIVAL(0),DIOUT)=1 Q
W:DINDEX("#")>1 !
S DIVAL(DISUB)=X
I X="",$G(DIY(DISUB))]"" S DIVAL(DISUB)=DIY(DISUB) S:DIC(0)'["O" DIC(0)=DIC(0)_"O"
Q:DIVAL(DISUB)=""
S DIVAL(0)=DIVAL(0)+1
S:$E(X)="^" (DIOUT,DUOUT)=1
Q
;
GETPRMT(DIC,DO,DINDEX,DIPRMT) ; Build list of prompts for each lookup value
N DICA I $D(DIC("A")) S DICA(1)=$G(DIC("A")) M DICA=DIC("A")
N DISUB,I,L,P S L=0
F DISUB=1:1:DINDEX("#") D
. I $G(DICA(DISUB))]"" D I DIPRMT(DISUB)]""
. . S DIPRMT(DISUB)=""
ANOTHER . . I DISUB=1,DINDEX("#")>1,DICA(DISUB)=$$EZBLD^DIALOG(8199) Q ;**CCO/NI 'ANOTHER ONE:'
. . S DIPRMT(DISUB)=DICA(DISUB) Q
. E D
. . S P=$S(DISUB=1:$P(DO,U),1:"")
. . I DISUB=1,$G(DICA(DISUB))=$$EZBLD^DIALOG(8199) S P=$$EZBLD^DIALOG(8050)_P
. . I DINDEX("#")=1,D'="B"&(DIC(0)["M")!(D="B"&(DO(2)'>1.9)) S DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P) Q
. . N X S X=DINDEX(DISUB,"PROMPT") I X]"" D
. . . I DISUB=1 Q:DINDEX("#")=1&(P[X!(X[P)) S P=P_" "
. . . S P=P_X Q
. . I DISUB=1 S DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P)
. . E S DIPRMT(DISUB)=P_": "
. . Q
. S I=$L(DIPRMT(DISUB)) S:I>L L=I Q
Q:DINDEX("#")=1
S I="",$P(I," ",L)=""
F DISUB=1:1:DINDEX("#") S DIPRMT(DISUB)=$E(I,1,(L-$L(DIPRMT(DISUB))))_DIPRMT(DISUB)
Q
;
TRYADD(DIC,DIFILEI) ; Return 1 if user should be allowed to attempt to add record
; when lookup value `ien and .01 is a pointer.
Q:DIC(0)'["L" 0
N % S %=$P($G(^DD(DIFILEI,.01,0)),U,2)
I %["P"!(%["V") Q 1
Q 0
;
; Error messages
; 204 The input value contains control characters.
; 208 Input value is an illegal number.
; 209 Input value is too long.
;8042 Select |1|:
;8050 Another
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC11 2967 printed Dec 13, 2024@02:45:19 Page 2
DIC11 ;SFISC/TKW-PROMPT USER FOR LOOKUP VALUES ;05:33 PM 11 Aug 2002
+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 ;
PROMPT NEW DIOUT
SET (DIVAL(0),DIOUT)=0
+1 FOR DISUB=1:1:DINDEX("#")
DO PR1
if DIOUT
QUIT
+2 SET X=$GET(DIVAL(1))
+3 ; W:$O(DIVAL(1)) !
IF DINDEX("#")>1
MERGE X=DIVAL
Begin DoDot:1
+4 IF X?1"^"1.E
KILL X
SET X=$GET(DIVAL(1))
QUIT
End DoDot:1
KILL X(0)
+5 QUIT
+6 ;
PR1 SET DIY=DIPRMT(DISUB)
SET DIVAL(DISUB)=""
NEW X
+1 IF $GET(DIY(DISUB))]""
SET DIY=DIY_$SELECT($DATA(DIY(DISUB,"EXT")):DIY(DISUB,"EXT"),1:DIY(DISUB))_"// "
+2 WRITE DIY
READ X:$SELECT($GET(DTIME):DTIME,1:300)
+3 IF '$TEST
SET (DIOUT,DTOUT)=1
WRITE $CHAR(7)
KILL DIVAL
SET DIVAL(0)=0
QUIT
+4 IF X'?.ANP
if DIC(0)["Q"
Begin DoDot:1
+5 WRITE $CHAR(7)," ",$$EZBLD^DIALOG(204),!
QUIT
End DoDot:1
SET DISUB=DISUB-1
QUIT
+6 IF X?1.N.1"."1.N
IF ($LENGTH($PIECE(X,"."))>25!($LENGTH($PIECE(X,".",2))>24))
if DIC(0)["Q"
Begin DoDot:1
+7 WRITE $CHAR(7)," ",$$EZBLD^DIALOG(208),!
QUIT
End DoDot:1
SET DISUB=DISUB-1
QUIT
+8 IF X="^"!($EXTRACT(X)="^"&(DISUB>1))
SET (DIOUT,DUOUT)=1
KILL DIVAL
SET DIVAL(0)=0
SET DIVAL(1)="^"
QUIT
+9 IF $LENGTH(X)>250
if DIC(0)["Q"
Begin DoDot:1
+10 WRITE $CHAR(7)," ",$$EZBLD^DIALOG(209),!
QUIT
End DoDot:1
SET DISUB=DISUB-1
QUIT
+11 IF X?1."?"
KILL DIVAL
SET DIVAL(1)=$EXTRACT(X,1,2)
SET DIVAL(0)=0
SET DIOUT=1
QUIT
+12 IF (X?1"`".NP)!(X=" ")
KILL DIVAL
SET DIVAL(1)=X
SET (DIVAL(0),DIOUT)=1
QUIT
+13 if DINDEX("#")>1
WRITE !
+14 SET DIVAL(DISUB)=X
+15 IF X=""
IF $GET(DIY(DISUB))]""
SET DIVAL(DISUB)=DIY(DISUB)
if DIC(0)'["O"
SET DIC(0)=DIC(0)_"O"
+16 if DIVAL(DISUB)=""
QUIT
+17 SET DIVAL(0)=DIVAL(0)+1
+18 if $EXTRACT(X)="^"
SET (DIOUT,DUOUT)=1
+19 QUIT
+20 ;
GETPRMT(DIC,DO,DINDEX,DIPRMT) ; Build list of prompts for each lookup value
+1 NEW DICA
IF $DATA(DIC("A"))
SET DICA(1)=$GET(DIC("A"))
MERGE DICA=DIC("A")
+2 NEW DISUB,I,L,P
SET L=0
+3 FOR DISUB=1:1:DINDEX("#")
Begin DoDot:1
+4 IF $GET(DICA(DISUB))]""
Begin DoDot:2
+5 SET DIPRMT(DISUB)=""
ANOTHER ;**CCO/NI 'ANOTHER ONE:'
IF DISUB=1
IF DINDEX("#")>1
IF DICA(DISUB)=$$EZBLD^DIALOG(8199)
QUIT
+1 SET DIPRMT(DISUB)=DICA(DISUB)
QUIT
End DoDot:2
IF DIPRMT(DISUB)]""
+2 IF '$TEST
Begin DoDot:2
+3 SET P=$SELECT(DISUB=1:$PIECE(DO,U),1:"")
+4 IF DISUB=1
IF $GET(DICA(DISUB))=$$EZBLD^DIALOG(8199)
SET P=$$EZBLD^DIALOG(8050)_P
+5 IF DINDEX("#")=1
IF D'="B"&(DIC(0)["M")!(D="B"&(DO(2)'>1.9))
SET DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P)
QUIT
+6 NEW X
SET X=DINDEX(DISUB,"PROMPT")
IF X]""
Begin DoDot:3
+7 IF DISUB=1
if DINDEX("#")=1&(P[X!(X[P))
QUIT
SET P=P_" "
+8 SET P=P_X
QUIT
End DoDot:3
+9 IF DISUB=1
SET DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P)
+10 IF '$TEST
SET DIPRMT(DISUB)=P_": "
+11 QUIT
End DoDot:2
+12 SET I=$LENGTH(DIPRMT(DISUB))
if I>L
SET L=I
QUIT
End DoDot:1
+13 if DINDEX("#")=1
QUIT
+14 SET I=""
SET $PIECE(I," ",L)=""
+15 FOR DISUB=1:1:DINDEX("#")
SET DIPRMT(DISUB)=$EXTRACT(I,1,(L-$LENGTH(DIPRMT(DISUB))))_DIPRMT(DISUB)
+16 QUIT
+17 ;
TRYADD(DIC,DIFILEI) ; Return 1 if user should be allowed to attempt to add record
+1 ; when lookup value `ien and .01 is a pointer.
+2 if DIC(0)'["L"
QUIT 0
+3 NEW %
SET %=$PIECE($GET(^DD(DIFILEI,.01,0)),U,2)
+4 IF %["P"!(%["V")
QUIT 1
+5 QUIT 0
+6 ;
+7 ; Error messages
+8 ; 204 The input value contains control characters.
+9 ; 208 Input value is an illegal number.
+10 ; 209 Input value is too long.
+11 ;8042 Select |1|:
+12 ;8050 Another
+13 ;
