DIR1 ;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;11:41 AM 8 Jun 2007
;;22.0;VA FileMan;**1,5,73,156**;Mar 30, 1999;Build 1
;Per VHA Directive 10-93-142, this routine should not be modified.
S %E=0 D @%T S:X?.E1C.E %E=1 Q:'%E!(X'?.E1L.E)!(%A["S")!(%A["Y")!((%T=1)&(%B["P"))!(%A["P")
F %Y=1:1:$L(X) I $E(X,%Y)?1L S X=$E(X,1,%Y-1)_$C($A(X,%Y)-32)_$E(X,%Y+1,999)
G DIR1
Y ; YES/NO
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")
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))
I %T="Y" S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%<0 (%,Y)="" S:%=2 Y=0
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 A0="Choose 1-"_%K_": " D MSG R %I:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME)
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
;
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="Response must not precede "_+$E(%B1,4,5)_"/"_+$E(%B1,6,7)_"/"_(1700+$E(%B1,1,3)) Q
I Y>%B2 S %E=1 S:'%N %W="Response must not follow "_+$E(%B2,4,5)_"/"_+$E(%B2,6,7)_"/"_(1700+$E(%B2,1,3))
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
I X>%B2!(X<%B1) S %E=1 S:'%N %W="Response must be no "_$S(X>%B2:"greater",1:"less")_" than "_$S(X>%B2:%B2,1:+%B1) Q
I '%E,($L($P(+X,".",2))>%B3) S %E=1 S:'%N %W="Response must be with no more than "_+%B3_" decimal digit"_$S(%B3>1:"s",1:"") Q
S Y=+X
Q
;
F ; FREETEXT
S Y=X I X[U,%A'["U" S %E=1
S:'%N %W="This response must have at least "_+%B1_" character"_$S(+%B1>1:"s",1:"")_" and no more than "_%B2_" characters"_$S(%A'["U":" and must not contain embedded uparrow",1:"")
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 D ^DIC
Q
;
1 ; DD
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
I %B["S" S %B=$P(%B3,U,3),%BU=$$UP^DILIBF(%B) X:$D(^DD(%B1,%B2,12.1)) ^(12.1) D S S X=Y,%B=$P(%B3,U,2) G R
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
. N %A,%B,%C,%N,%P,%T,%W 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
. X $P(%B3,U,5,99)
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
DIR1 ;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;11:41 AM 8 Jun 2007
+1 ;;22.0;VA FileMan;**1,5,73,156**;Mar 30, 1999;Build 1
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET %E=0
DO @%T
IF X?.E1C.E
SET %E=1
IF '%E!(X'?.E1L.E)!(%A["S")!(%A["Y")!((%T=1)&(%B["P"))!(%A["P")
QUIT
+4 FOR %Y=1:1:$LENGTH(X)
IF $EXTRACT(X,%Y)?1L
SET X=$EXTRACT(X,1,%Y-1)_$CHAR($ASCII(X,%Y)-32)_$EXTRACT(X,%Y+1,999)
+5 GOTO DIR1
Y ; YES/NO
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 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 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))
+31 IF %T="Y"
SET (%,Y)=+$$PRS^DIALOGU(7001,$EXTRACT(X))
IF %<0
SET (%,Y)=""
IF %=2
SET Y=0
+32 QUIT
+33 ;
CH ;
+1 NEW DIY,DDD,DDC,DS,DD
+2 FOR %I=1:1:%K
SET A0=" "_%I_" "_$PIECE(%K(%I),":",2)
DO MSG
+3 IF '$DATA(DDS)
SET A0="Choose 1-"_%K_": "
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)
+7 QUIT
+8 ;
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 IF %B1
IF Y<%B1
SET %E=1
IF '%N
SET %W="Response must not precede "_+$EXTRACT(%B1,4,5)_"/"_+$EXTRACT(%B1,6,7)_"/"_(1700+$EXTRACT(%B1,1,3))
QUIT
+4 IF Y>%B2
SET %E=1
IF '%N
SET %W="Response must not follow "_+$EXTRACT(%B2,4,5)_"/"_+$EXTRACT(%B2,6,7)_"/"_(1700+$EXTRACT(%B2,1,3))
+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
+3 IF X>%B2!(X<%B1)
SET %E=1
IF '%N
SET %W="Response must be no "_$SELECT(X>%B2:"greater",1:"less")_" than "_$SELECT(X>%B2:%B2,1:+%B1)
QUIT
+4 IF '%E
IF ($LENGTH($PIECE(+X,".",2))>%B3)
SET %E=1
IF '%N
SET %W="Response must be with no more than "_+%B3_" decimal digit"_$SELECT(%B3>1:"s",1:"")
QUIT
+5 SET Y=+X
+6 QUIT
+7 ;
F ; FREETEXT
+1 SET Y=X
IF X[U
IF %A'["U"
SET %E=1
+2 IF '%N
SET %W="This response must have at least "_+%B1_" character"_$SELECT(+%B1>1:"s",1:"")_" and no more than "_%B2_" characters"_$SELECT(%A'["U":" and must not contain embedded uparrow",1:"")
+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
DO ^DIC
+1 QUIT
+2 ;
1 ; DD
+1 SET %C=X
NEW %W
IF %B["P"!(%B["V")
NEW DIE
+2 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 IF %B["S"
SET %B=$PIECE(%B3,U,3)
SET %BU=$$UP^DILIBF(%B)
IF $DATA(^DD(%B1,%B2,12.1))
XECUTE ^(12.1)
DO S
SET X=Y
SET %B=$PIECE(%B3,U,2)
GOTO R
+4 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
+5 IF %B["V"
Begin DoDot:1
+6 NEW %A,%B,%C,%N,%P,%T,%W
+7 SET (DIE,DP)=%B1
SET DIFLD=%B2
SET DQ=1
+8 DO ^DIE3
+9 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
IT Begin DoDot:1
+1 NEW %A,%B,%C,%N,%P,%T,%W
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 XECUTE $PIECE(%B3,U,5,99)
End DoDot:1
+4 SET %E='$DATA(X)
+5 IF '%E
IF %B'["P"
SET Y=X
+6 IF '%E
IF %B["D"
XECUTE ^DD("DD")
SET Y(0)=Y
SET Y=X
+7 QUIT
+8 ;
+9 ;#7001 Yes/No question
