DIR1 ;SFISC/XAK - PROCESS DATATYPE ;9MAY2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;;GFT;**1,5,73,999,1004,1022,1024,1037,1053,1054**
;
S %E=0 D @%T
S:X?.E1C.E %E=1 Q:'%E!(X'?.E1L.E)!(%A["S")!(%A["Y")!((%T=1)&((%B["P")!(%B["S")))!(%A["P")
S X=$$UP^DILIBF(X) ;**CCO/NI UPPERCASE TRANSLATION
G DIR1
0 Q
;
;
Y ; YES/NO
;I $G(DUZ("LANG"))>1,$G(%B)]"" S %J=$F("YN",$$UP^DILIBF($E(X))) I %J S X=$P($P(%B,";",%J-1),":",2) ;YES/NO in FOREIGN LANGUAGE -- defect 265656
;FALL THRU HERE BECAUSE 'YES/NO' IS A FORM OF A 'SET' TYPE
S ; SET
N %BU,%K,%M,%J,DDH
I $L(X)>245 S %E=1,Y="" Q ;DI*156
I %T="S",$D(DIR("S"))#2 S DIC("S")=DIR("S")
S %BA=$S($D(DIC("S")):DIC("S"),1:"I 1") ;SCREEN the input
S (%J,%K,DDH)=0
I %B'[":",$O(DIR("C",""))]"" D
. ;Look for match on internal code
. S %I="" F S %I=$O(DIR("C",%I)) Q:%I="" S %J=DIR("C",%I) I X=$P(%J,":") S Y=X,Y(0)=$P(%J,":",2) X %BA S:'$T %I="" Q
. ;If not found, look for match on external code
. I %I="" F S %I=$O(DIR("C",%I)) Q:%I="" S %J=DIR("C",%I) I $F(%J,":"_X) S Y=$P(%J,":") X %BA I S %K=%K+1,%K(%K)=%J Q:%A["o" I $D(DIQUIET),X=$P(%J,":",2) Q
. ;If still no match, convert X and choices to uppercase, search again
. I %I="",%A'["X",'%K D
.. S %M=X N X S X=$$UP^DILIBF(%M)
.. F S %I=$O(DIR("C",%I)) Q:%I="" S %J1=DIR("C",%I),%J=$$UP^DILIBF(%J1) I X=$P(%J,":") S Y=$P(%J1,":"),Y(0)=$P(%J1,":",2) X %BA S:'$T %I="" Q
.. I %I="" F S %I=$O(DIR("C",%I)) Q:%I="" S %J1=DIR("C",%I),%J=$$UP^DILIBF(%J1) I $F(%J,":"_X) S Y=$P(%J1,":") X %BA I S %K=%K+1,%K(%K)=%J1 Q:%A["o" I $D(DIQUIET),X=$P(%J,":",2) Q
. S %J=%I
E D
. S Y(0)=$P($P(";"_%B,";"_X_":",2),";") I Y(0)]"" S Y=X X %BA I S %J=1
. I '%J F %I=1:1 S %J=$P(%B,";",%I) Q:%J="" S Y=$F(%J,":"_X) I Y S Y=$P(%J,":") X %BA I S %K=%K+1,%K(%K)=%J Q:%A["o" I $D(DIQUIET),X=$P(%J,":",2) Q
. I %J="",%A'["X",'%K D
.. S %BU=$$UP^DILIBF(%B),%M=X N X S X=$$UP^DILIBF(%M)
.. S Y=$F(";"_%BU,";"_X_":") I Y D X %BA I S %J=1 Q
... S Y(0)=$P($E(";"_%B,Y,999),";")
... S Y=$L($E(";"_%B,1,Y-1),";"),Y=$P($P(";"_%B,";",Y),":")
.. F %I=1:1 S %J=$P(%BU,";",%I),%J1=$P(%B,";",%I) Q:%J="" S Y=$F(%J,":"_X) I Y S Y=$P(%J1,":") X %BA I S %K=%K+1,%K(%K)=%J1 Q:%A["o" I $D(DIQUIET),X=$P(%J,":",2) Q
I %K=1 S Y=$P(%K(1),":"),Y(0)=$P(%K(1),":",2)
I %K>1,$G(DIQUIET) S %E=1 Q
I %K>1 D CH Q:%E=1 I '$D(%K(%I)) S X=%I G S
I %J="",'%K S %E=1 Q
I %A'["V",$D(DDS)[0 W $S((%K=1!('%K))&($P(Y(0),X)=""):$E(Y(0),$L(X)+1,99),1:" "_Y(0)) ;HERE WRITE OUT THE REST OF WHAT THEY TYPED
7001 I %T="Y" S Y="" D ;S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%=2 Y=0 D:%<0 ;DIALOG 7001 may not have translation
.S:$P($P(%B,";"),":",2)=Y(0) Y=1 S:$P($P(%B,";",2),":",2)=Y(0) Y=0 S %=Y ;1=YES,0=NO
Q
;
CH ;
N DIY,DDD,DDC,DS,DD
F %I=1:1:%K S A0=" "_%I_" "_$P(%K(%I),":",2) D MSG
I '$D(DDS) S DIY(1)=1,DIY(2)=%K,A0=$$EZBLD^DIALOG(8088,.DIY) K DIY D MSG R %I:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME) ;'CHOOSE 1-N'
I $D(DDS) S DDD=2,DDC=5,(DS,DD)=%K D LIST^DDSU S %I=DIY
I U[%I!(%I?1."?") S X="?",%E=1 Q
I $D(%K(%I)) S Y=$P(%K(%I),":"),Y(0)=$P(%K(%I),":",2) Q
I %I?.N S %E=1
Q
;
MSG ;
I $D(DDS),A0]"" S DDH=$G(DDH)+1,DS(DDH)=$P(%K(%I),":"),DDH(DDH,DDH)=$P(%K(%I),":",2)
I '$D(DDS) W !,A0
K A0
Q
;
L ; LIST OR RANGE
D L^DIR3
Q
D ; DATE
D ^%DT I Y<0 S %E=1 Q
I %D1["NOW"!(%D2["NOW")&($P("NOW",$$UP^DILIBF(X))="") S:%D1["NOW" %B1=Y S:%D2["NOW" %B2=Y
I %B1,Y<%B1 S %E=1 S:'%N %W=$$EZBLD^DIALOG(9114.1,$$DATE^DIUTL(%B1)) Q ;**CCO/NI 'RESPONSE MUST NOT PRECEDE (DATE)'
I Y>%B2 S %E=1 S:'%N %W=$$EZBLD^DIALOG(9114.2,$$DATE^DIUTL(%B2)) ;**CCO/NI 'RESPONSE MUST NOT FOLLOW (DATE)'
S Y(1)=Y X ^DD("DD") S Y(0)=Y,Y=Y(1) K Y(1)
Q
;
N ; NUMERIC
I $L($P(X,"."))>24 S %E=1 Q
I X'?.1"-".N.1".".N S %E=1 Q
GL I X>%B2!(X<%B1) S %E=1 D:'%N Q ;**CCO/NI 'RESPONSE MUST NOT BE BIGGER/SMALLER'
.N I S I(1)=+%B1,I(2)=+%B2,%W=$$EZBLD^DIALOG(212,.I) ;**CCO/NI 'DECIMAL DIGITS' (plus next line)
DEC I '%E,($L($P(+X,".",2))>%B3) S %E=1 S:'%N %W=$$EZBLD^DIALOG(211,+%B3) Q
S Y=+X
Q
;
F ; FREETEXT
S Y=X I X[U,%A'["U" S %E=1
I '%N N I S I(1)=+%B1,I(2)=+%B2,%W=$$EZBLD^DIALOG(213,.I) S:%A'["U" %W=%W_" "_$$EZBLD^DIALOG(214) ;**CCO/NI EMBEDDED UPARROW
I $L(X)<%B1!($L(X)>%B2) S %E=1
Q
;
E ; END-OF-PAGE
S Y=X="" S:X=U (DUOUT,DIRUT)=1 I $L(X),X'=U S %E=1
Q
;
P ; POINTER
S:'$D(DDS) %B2=$P(%B2,"L")_$P(%B2,"L",2)
I %B2["A" S %B2=$P(%B2,"A")_$P(%B2,"A",2)
S:$D(DIR("S"))#2 DIC("S")=DIR("S")
S DIC=%B1,DIC(0)=%B2,%C=X D P1
I $D(X)#2,X="",Y<0 S %E=-1
E S %E=Y<0
S X=%C
Q
P1 N %A,%B,%C,%N,%P,%T,%W
F K DICQRETV,DICQRETA D ^DIC Q:Y>0!'$D(DICQRETV) S X=DICQRETV,DIC(0)=DIC(0)_"O" ;MOUSE MIGHT CLICK ON AN PARTIAL MATCH
Q
;
1 ; DATA-DICTIONARY TYPE OF READ
S %C=X N %W I %B["P"!(%B["V") N DIE
I %B["F" S Y=X I X[U,$P($P(%B3,U,4),";",2)'?1"E"1.N1","1.N S %E=1 Q ;CAN'T CONTAIN "^" UNLESS STORED BY $E
G R:$P(%B,"t",2) ;EXTENSIBLE DATA TYPE
I %B["S" S %B=$P(%B3,U,3) D S X=Y,%B=$P(%B3,U,2) G R
.N DILANG
.I $G(DUZ("LANG"))>1,$D(^DD(%B1,%B2,0)) S DILANG=$$SETIN^DIALOGZ D
..I DILANG'=%B S %B=DILANG Q
..K DILANG
.S %BU=$$UP^DILIBF(%B) D SETSCR^DIR(%B1,%B2),S
.I $D(DILANG) N % S %=$F(";"_DILANG,";"_Y) I % S Y=$P($P($P(^DD(%B1,%B2,0),U,3),";",Y),":") ;Return the 'REAL' internal value
I %B["P" S DIC=U_$P(%B3,U,3),DIE=DIC,DIC(0)=$E("L",%B'["'"&$D(DDS))_$E("E",$D(DIR("V"))[0)_"MZ" I %B'["*" D P1 S X=+Y,%E=Y<0
I %B["V" D
. N %A,%B,%C,%N,%P,%T,%W
. S (DIE,DP)=%B1,DIFLD=%B2,DQ=1
. D ^DIE3
. S %E=Y'>0 S:Y>0 Y(0)=$P(Y,U,2)
R D IT:'%E S X=%C
Q
;
IT D ;INPUT TRANSFORM
. N %A,%B,%C,%N,%P,%T,%W,DIPA N:'$G(DIRDINUM) DINUM
. I $P(%B3,U,2)["N",$P(%B3,U,5,99)'["$",X?.1"-".N.1".".N,$P(%B3,U,5,99)["+X'=X" S X=+X
.I $D(DDS) N DIQUIET S DIQUIET=1
.X $S($P(%B3,U,2)'["t":$P(%B3,U,5,99),1:$$VALEXT^DIETLIBF(%B1,%B2)) ;E.G., D READSET^DIED(.X,"1:TRUE;0:FALSE;")
S %E='$D(X)
I '%E,%B'["P" S Y=X
I '%E,%B["D" X ^DD("DD") S Y(0)=Y,Y=X
Q
;
;#7001 Yes/No question
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIR1 6312 printed Apr 09, 2024@21:53:43 Page 2
DIR1 ;SFISC/XAK - PROCESS DATATYPE ;9MAY2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;;GFT;**1,5,73,999,1004,1022,1024,1037,1053,1054**
+7 ;
+8 SET %E=0
DO @%T
+9 if X?.E1C.E
SET %E=1
if '%E!(X'?.E1L.E)!(%A["S")!(%A["Y")!((%T=1)&((%B["P")!(%B["S")))!(%A["P")
QUIT
+10 ;**CCO/NI UPPERCASE TRANSLATION
SET X=$$UP^DILIBF(X)
+11 GOTO DIR1
0 QUIT
+1 ;
+2 ;
Y ; YES/NO
+1 ;I $G(DUZ("LANG"))>1,$G(%B)]"" S %J=$F("YN",$$UP^DILIBF($E(X))) I %J S X=$P($P(%B,";",%J-1),":",2) ;YES/NO in FOREIGN LANGUAGE -- defect 265656
+2 ;FALL THRU HERE BECAUSE 'YES/NO' IS A FORM OF A 'SET' TYPE
S ; SET
+1 NEW %BU,%K,%M,%J,DDH
+2 ;DI*156
IF $LENGTH(X)>245
SET %E=1
SET Y=""
QUIT
+3 IF %T="S"
IF $DATA(DIR("S"))#2
SET DIC("S")=DIR("S")
+4 ;SCREEN the input
SET %BA=$SELECT($DATA(DIC("S")):DIC("S"),1:"I 1")
+5 SET (%J,%K,DDH)=0
+6 IF %B'[":"
IF $ORDER(DIR("C",""))]""
Begin DoDot:1
+7 ;Look for match on internal code
+8 SET %I=""
FOR
SET %I=$ORDER(DIR("C",%I))
if %I=""
QUIT
SET %J=DIR("C",%I)
IF X=$PIECE(%J,":")
SET Y=X
SET Y(0)=$PIECE(%J,":",2)
XECUTE %BA
if '$TEST
SET %I=""
QUIT
+9 ;If not found, look for match on external code
+10 IF %I=""
FOR
SET %I=$ORDER(DIR("C",%I))
if %I=""
QUIT
SET %J=DIR("C",%I)
IF $FIND(%J,":"_X)
SET Y=$PIECE(%J,":")
XECUTE %BA
IF $TEST
SET %K=%K+1
SET %K(%K)=%J
if %A["o"
QUIT
IF $DATA(DIQUIET)
IF X=$PIECE(%J,":",2)
QUIT
+11 ;If still no match, convert X and choices to uppercase, search again
+12 IF %I=""
IF %A'["X"
IF '%K
Begin DoDot:2
+13 SET %M=X
NEW X
SET X=$$UP^DILIBF(%M)
+14 FOR
SET %I=$ORDER(DIR("C",%I))
if %I=""
QUIT
SET %J1=DIR("C",%I)
SET %J=$$UP^DILIBF(%J1)
IF X=$PIECE(%J,":")
SET Y=$PIECE(%J1,":")
SET Y(0)=$PIECE(%J1,":",2)
XECUTE %BA
if '$TEST
SET %I=""
QUIT
+15 IF %I=""
FOR
SET %I=$ORDER(DIR("C",%I))
if %I=""
QUIT
SET %J1=DIR("C",%I)
SET %J=$$UP^DILIBF(%J1)
IF $FIND(%J,":"_X)
SET Y=$PIECE(%J1,":")
XECUTE %BA
IF $TEST
SET %K=%K+1
SET %K(%K)=%J1
if %A["o"
QUIT
IF $DATA(DIQUIET)
IF X=$PIECE(%J,":",2)
QUIT
End DoDot:2
+16 SET %J=%I
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET Y(0)=$PIECE($PIECE(";"_%B,";"_X_":",2),";")
IF Y(0)]""
SET Y=X
XECUTE %BA
IF $TEST
SET %J=1
+19 IF '%J
FOR %I=1:1
SET %J=$PIECE(%B,";",%I)
if %J=""
QUIT
SET Y=$FIND(%J,":"_X)
IF Y
SET Y=$PIECE(%J,":")
XECUTE %BA
IF $TEST
SET %K=%K+1
SET %K(%K)=%J
if %A["o"
QUIT
IF $DATA(DIQUIET)
IF X=$PIECE(%J,":",2)
QUIT
+20 IF %J=""
IF %A'["X"
IF '%K
Begin DoDot:2
+21 SET %BU=$$UP^DILIBF(%B)
SET %M=X
NEW X
SET X=$$UP^DILIBF(%M)
+22 SET Y=$FIND(";"_%BU,";"_X_":")
IF Y
Begin DoDot:3
+23 SET Y(0)=$PIECE($EXTRACT(";"_%B,Y,999),";")
+24 SET Y=$LENGTH($EXTRACT(";"_%B,1,Y-1),";")
SET Y=$PIECE($PIECE(";"_%B,";",Y),":")
End DoDot:3
XECUTE %BA
IF $TEST
SET %J=1
QUIT
+25 FOR %I=1:1
SET %J=$PIECE(%BU,";",%I)
SET %J1=$PIECE(%B,";",%I)
if %J=""
QUIT
SET Y=$FIND(%J,":"_X)
IF Y
SET Y=$PIECE(%J1,":")
XECUTE %BA
IF $TEST
SET %K=%K+1
SET %K(%K)=%J1
if %A["o"
QUIT
IF $DATA(DIQUIET)
IF X=$PIECE(%J,":",2)
QUIT
End DoDot:2
End DoDot:1
+26 IF %K=1
SET Y=$PIECE(%K(1),":")
SET Y(0)=$PIECE(%K(1),":",2)
+27 IF %K>1
IF $GET(DIQUIET)
SET %E=1
QUIT
+28 IF %K>1
DO CH
if %E=1
QUIT
IF '$DATA(%K(%I))
SET X=%I
GOTO S
+29 IF %J=""
IF '%K
SET %E=1
QUIT
+30 ;HERE WRITE OUT THE REST OF WHAT THEY TYPED
IF %A'["V"
IF $DATA(DDS)[0
WRITE $SELECT((%K=1!('%K))&($PIECE(Y(0),X)=""):$EXTRACT(Y(0),$LENGTH(X)+1,99),1:" "_Y(0))
7001 ;S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%=2 Y=0 D:%<0 ;DIALOG 7001 may not have translation
IF %T="Y"
SET Y=""
Begin DoDot:1
+1 ;1=YES,0=NO
if $PIECE($PIECE(%B,";"),"
SET Y=1
if $PIECE($PIECE(%B,";",2),"
SET Y=0
SET %=Y
End DoDot:1
+2 QUIT
+3 ;
CH ;
+1 NEW DIY,DDD,DDC,DS,DD
+2 FOR %I=1:1:%K
SET A0=" "_%I_" "_$PIECE(%K(%I),":",2)
DO MSG
+3 ;'CHOOSE 1-N'
IF '$DATA(DDS)
SET DIY(1)=1
SET DIY(2)=%K
SET A0=$$EZBLD^DIALOG(8088,.DIY)
KILL DIY
DO MSG
READ %I:$SELECT($DATA(DIR("T")):DIR("T"),'$DATA(DTIME):300,1:DTIME)
+4 IF $DATA(DDS)
SET DDD=2
SET DDC=5
SET (DS,DD)=%K
DO LIST^DDSU
SET %I=DIY
+5 IF U[%I!(%I?1."?")
SET X="?"
SET %E=1
QUIT
+6 IF $DATA(%K(%I))
SET Y=$PIECE(%K(%I),":")
SET Y(0)=$PIECE(%K(%I),":",2)
QUIT
+7 IF %I?.N
SET %E=1
+8 QUIT
+9 ;
MSG ;
+1 IF $DATA(DDS)
IF A0]""
SET DDH=$GET(DDH)+1
SET DS(DDH)=$PIECE(%K(%I),":")
SET DDH(DDH,DDH)=$PIECE(%K(%I),":",2)
+2 IF '$DATA(DDS)
WRITE !,A0
+3 KILL A0
+4 QUIT
+5 ;
L ; LIST OR RANGE
+1 DO L^DIR3
+2 QUIT
D ; DATE
+1 DO ^%DT
IF Y<0
SET %E=1
QUIT
+2 IF %D1["NOW"!(%D2["NOW")&($PIECE("NOW",$$UP^DILIBF(X))="")
if %D1["NOW"
SET %B1=Y
if %D2["NOW"
SET %B2=Y
+3 ;**CCO/NI 'RESPONSE MUST NOT PRECEDE (DATE)'
IF %B1
IF Y<%B1
SET %E=1
if '%N
SET %W=$$EZBLD^DIALOG(9114.1,$$DATE^DIUTL(%B1))
QUIT
+4 ;**CCO/NI 'RESPONSE MUST NOT FOLLOW (DATE)'
IF Y>%B2
SET %E=1
if '%N
SET %W=$$EZBLD^DIALOG(9114.2,$$DATE^DIUTL(%B2))
+5 SET Y(1)=Y
XECUTE ^DD("DD")
SET Y(0)=Y
SET Y=Y(1)
KILL Y(1)
+6 QUIT
+7 ;
N ; NUMERIC
+1 IF $LENGTH($PIECE(X,"."))>24
SET %E=1
QUIT
+2 IF X'?.1"-".N.1".".N
SET %E=1
QUIT
GL ;**CCO/NI 'RESPONSE MUST NOT BE BIGGER/SMALLER'
IF X>%B2!(X<%B1)
SET %E=1
if '%N
Begin DoDot:1
+1 ;**CCO/NI 'DECIMAL DIGITS' (plus next line)
NEW I
SET I(1)=+%B1
SET I(2)=+%B2
SET %W=$$EZBLD^DIALOG(212,.I)
End DoDot:1
QUIT
DEC IF '%E
IF ($LENGTH($PIECE(+X,".",2))>%B3)
SET %E=1
if '%N
SET %W=$$EZBLD^DIALOG(211,+%B3)
QUIT
+1 SET Y=+X
+2 QUIT
+3 ;
F ; FREETEXT
+1 SET Y=X
IF X[U
IF %A'["U"
SET %E=1
+2 ;**CCO/NI EMBEDDED UPARROW
IF '%N
NEW I
SET I(1)=+%B1
SET I(2)=+%B2
SET %W=$$EZBLD^DIALOG(213,.I)
if %A'["U"
SET %W=%W_" "_$$EZBLD^DIALOG(214)
+3 IF $LENGTH(X)<%B1!($LENGTH(X)>%B2)
SET %E=1
+4 QUIT
+5 ;
E ; END-OF-PAGE
+1 SET Y=X=""
if X=U
SET (DUOUT,DIRUT)=1
IF $LENGTH(X)
IF X'=U
SET %E=1
+2 QUIT
+3 ;
P ; POINTER
+1 if '$DATA(DDS)
SET %B2=$PIECE(%B2,"L")_$PIECE(%B2,"L",2)
+2 IF %B2["A"
SET %B2=$PIECE(%B2,"A")_$PIECE(%B2,"A",2)
+3 if $DATA(DIR("S"))#2
SET DIC("S")=DIR("S")
+4 SET DIC=%B1
SET DIC(0)=%B2
SET %C=X
DO P1
+5 IF $DATA(X)#2
IF X=""
IF Y<0
SET %E=-1
+6 IF '$TEST
SET %E=Y<0
+7 SET X=%C
+8 QUIT
P1 NEW %A,%B,%C,%N,%P,%T,%W
+1 ;MOUSE MIGHT CLICK ON AN PARTIAL MATCH
FOR
KILL DICQRETV,DICQRETA
DO ^DIC
if Y>0!'$DATA(DICQRETV)
QUIT
SET X=DICQRETV
SET DIC(0)=DIC(0)_"O"
+2 QUIT
+3 ;
1 ; DATA-DICTIONARY TYPE OF READ
+1 SET %C=X
NEW %W
IF %B["P"!(%B["V")
NEW DIE
+2 ;CAN'T CONTAIN "^" UNLESS STORED BY $E
IF %B["F"
SET Y=X
IF X[U
IF $PIECE($PIECE(%B3,U,4),";",2)'?1"E"1.N1","1.N
SET %E=1
QUIT
+3 ;EXTENSIBLE DATA TYPE
if $PIECE(%B,"t",2)
GOTO R
+4 IF %B["S"
SET %B=$PIECE(%B3,U,3)
Begin DoDot:1
+5 NEW DILANG
+6 IF $GET(DUZ("LANG"))>1
IF $DATA(^DD(%B1,%B2,0))
SET DILANG=$$SETIN^DIALOGZ
Begin DoDot:2
+7 IF DILANG'=%B
SET %B=DILANG
QUIT
+8 KILL DILANG
End DoDot:2
+9 SET %BU=$$UP^DILIBF(%B)
DO SETSCR^DIR(%B1,%B2)
DO S
+10 ;Return the 'REAL' internal value
IF $DATA(DILANG)
NEW %
SET %=$FIND(";"_DILANG,";"_Y)
IF %
SET Y=$PIECE($PIECE($PIECE(^DD(%B1,%B2,0),U,3),";",Y),":")
End DoDot:1
SET X=Y
SET %B=$PIECE(%B3,U,2)
GOTO R
+11 IF %B["P"
SET DIC=U_$PIECE(%B3,U,3)
SET DIE=DIC
SET DIC(0)=$EXTRACT("L",%B'["'"&$DATA(DDS))_$EXTRACT("E",$DATA(DIR("V"))[0)_"MZ"
IF %B'["*"
DO P1
SET X=+Y
SET %E=Y<0
+12 IF %B["V"
Begin DoDot:1
+13 NEW %A,%B,%C,%N,%P,%T,%W
+14 SET (DIE,DP)=%B1
SET DIFLD=%B2
SET DQ=1
+15 DO ^DIE3
+16 SET %E=Y'>0
if Y>0
SET Y(0)=$PIECE(Y,U,2)
End DoDot:1
R if '%E
DO IT
SET X=%C
+1 QUIT
+2 ;
IT ;INPUT TRANSFORM
Begin DoDot:1
+1 NEW %A,%B,%C,%N,%P,%T,%W,DIPA
if '$GET(DIRDINUM)
NEW DINUM
+2 IF $PIECE(%B3,U,2)["N"
IF $PIECE(%B3,U,5,99)'["$"
IF X?.1"-".N.1".".N
IF $PIECE(%B3,U,5,99)["+X'=X"
SET X=+X
+3 IF $DATA(DDS)
NEW DIQUIET
SET DIQUIET=1
+4 ;E.G., D READSET^DIED(.X,"1:TRUE;0:FALSE;")
XECUTE $SELECT($PIECE(%B3,U,2)'["t":$PIECE(%B3,U,5,99),1:$$VALEXT^DIETLIBF(%B1,%B2))
End DoDot:1
+5 SET %E='$DATA(X)
+6 IF '%E
IF %B'["P"
SET Y=X
+7 IF '%E
IF %B["D"
XECUTE ^DD("DD")
SET Y(0)=Y
SET Y=X
+8 QUIT
+9 ;
+10 ;#7001 Yes/No question
