DIC11 ;SFISC/TKW-PROMPT USER FOR LOOKUP VALUES ;1:33 PM 26 Dec 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**1,13,40,67**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
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)=""
. . I DISUB=1,DINDEX("#")>1,DICA(DISUB)="ANOTHER ONE: " Q
. . S DIPRMT(DISUB)=DICA(DISUB) Q
. E D
. . S P=$S(DISUB=1:$P(DO,U),1:"")
. . I DISUB=1,$G(DICA(DISUB))="ANOTHER ONE: " 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
;
DIC11 ;SFISC/TKW-PROMPT USER FOR LOOKUP VALUES ;1:33 PM 26 Dec 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**1,13,40,67**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
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)=""
+6 IF DISUB=1
IF DINDEX("#")>1
IF DICA(DISUB)="ANOTHER ONE: "
QUIT
+7 SET DIPRMT(DISUB)=DICA(DISUB)
QUIT
End DoDot:2
IF DIPRMT(DISUB)]""
+8 IF '$TEST
Begin DoDot:2
+9 SET P=$SELECT(DISUB=1:$PIECE(DO,U),1:"")
+10 IF DISUB=1
IF $GET(DICA(DISUB))="ANOTHER ONE: "
SET P=$$EZBLD^DIALOG(8050)_P
+11 IF DINDEX("#")=1
IF D'="B"&(DIC(0)["M")!(D="B"&(DO(2)'>1.9))
SET DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P)
QUIT
+12 NEW X
SET X=DINDEX(DISUB,"PROMPT")
IF X]""
Begin DoDot:3
+13 IF DISUB=1
IF DINDEX("#")=1&(P[X!(X[P))
QUIT
SET P=P_" "
+14 SET P=P_X
QUIT
End DoDot:3
+15 IF DISUB=1
SET DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P)
+16 IF '$TEST
SET DIPRMT(DISUB)=P_": "
+17 QUIT
End DoDot:2
+18 SET I=$LENGTH(DIPRMT(DISUB))
IF I>L
SET L=I
QUIT
End DoDot:1
+19 IF DINDEX("#")=1
QUIT
+20 SET I=""
SET $PIECE(I," ",L)=""
+21 FOR DISUB=1:1:DINDEX("#")
SET DIPRMT(DISUB)=$EXTRACT(I,1,(L-$LENGTH(DIPRMT(DISUB))))_DIPRMT(DISUB)
+22 QUIT
+23 ;
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 ;
