- 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 Mar 13, 2025@21:58:44 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
