Return to DIR1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIR1	;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;11/23/94  14:36
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	S %E=0 D @%T I %A["X"!'%E!(X?.UNP) K %BU,%K Q
    5: 	S %M=X 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)
    6: 	G DIR1
    7: Y	; YES/NO
    8: S	; SET
    9: 	I $L(X)>245 S %E=1 Q
   10: 	I %T="S",$D(DIR("S"))#2 S DIC("S")=DIR("S")
   11: 	I %A["M" S %BU=$$UP^DILIBF(%B)
   12: 	S %BA=$S($D(DIC("S")):DIC("S"),1:"I 1")
   13: 	S (%J,%K,DDH)=0,Y(0)=$P($P(";"_%B,";"_X_":",2),";") I Y(0)]"" S Y=X X %BA I  S %J=1
   14: 	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
   15: 	I %J="",$D(%BU),'%K 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
   16: 	I %K=1 S Y=$P(%K(1),":"),Y(0)=$P(%K(1),":",2)
   17: 	I %K>1,$G(DIQUIET) S %E=1 Q
   18: 	I %K>1 D CH Q:%E=1  I '$D(%K(%I)) S X=%I G S
   19: 	I %J="",'%K S %E=1 Q
   20: 	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))
   21: 	I %T="Y" S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%<0 (%,Y)="" S:%=2 Y=0
   22: 	I '%E,$G(%M)]"" S X=%M K %M
   23: 	Q
   24: 	;
   25: CH	;
   26: 	N DIY,DDD,DDC,DS,DD
   27: 	F %I=1:1:%K S A0="     "_%I_"   "_$P(%K(%I),":",2) D MSG
   28: 	I '$D(DDS) S A0="Choose 1-"_%K_": " D MSG R %I:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME)
   29: 	I $D(DDS) S DDD=2,DDC=5,(DS,DD)=%K D LIST^DDSU S %I=DIY
   30: 	I U[%I!(%I?1."?") S X="?",%E=1 Q
   31: 	I $D(%K(%I)) S Y=$P(%K(%I),":"),Y(0)=$P(%K(%I),":",2)
   32: 	Q
   33: 	;
   34: MSG	;
   35: 	I $D(DDS),A0]"" S DDH=$G(DDH)+1,DS(DDH)=$P(%K(%I),":"),DDH(DDH,DDH)=$P(%K(%I),":",2)
   36: 	I '$D(DDS) W !,A0
   37: 	K A0
   38: 	Q
   39: 	;
   40: L	; LIST OR RANGE
   41: 	D L^DIR3
   42: 	Q
   43: D	; DATE
   44: 	D ^%DT I Y<0 S %E=1 Q
   45: 	I %D1["NOW"!(%D2["NOW")&($P("NOW",$$UP^DILIBF(X))="") S:%D1["NOW" %B1=Y S:%D2["NOW" %B2=Y
   46: 	I %B1,Y<%B1 S %E=1 S:'%N %W="Response must not be previous to "_+$E(%B1,4,5)_"/"_+$E(%B1,6,7)_"/"_$E(%B1,2,3) Q
   47: 	I Y>%B2 S %E=1 S:'%N %W="Response must not be following "_+$E(%B2,4,5)_"/"_+$E(%B2,6,7)_"/"_$E(%B2,2,3)
   48: 	S Y(1)=Y X ^DD("DD") S Y(0)=Y,Y=Y(1) K Y(1)
   49: 	Q
   50: 	;
   51: N	; NUMERIC
   52: 	I $L($P(X,"."))>24 S %E=1 Q
   53: 	I X'?.1"-".N.1".".N S %E=1 Q
   54: 	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
   55: 	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
   56: 	S Y=+X
   57: 	Q
   58: 	;
   59: F	; FREETEXT
   60: 	S Y=X I X[U,%A'["U" S %E=1
   61: 	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:"")
   62: 	I $L(X)<%B1!($L(X)>%B2) S %E=1
   63: 	Q
   64: 	;
   65: E	; END-OF-PAGE
   66: 	S Y=X="" S:X=U (DUOUT,DIRUT)=1 I $L(X),X'=U S %E=1
   67: 	Q
   68: 	;
   69: P	; POINTER
   70: 	S:'$D(DDS) %B2=$P(%B2,"L")_$P(%B2,"L",2)
   71: 	I %B2["A" S %B2=$P(%B2,"A")_$P(%B2,"A",2)
   72: 	S:$D(DIR("S"))#2 DIC("S")=DIR("S")
   73: 	S DIC=%B1,DIC(0)=%B2,%C=X D P1 S X=%C
   74: 	S %E=Y<0
   75: 	Q
   76: P1	N %A,%B,%C,%N,%P,%T,%W D ^DIC
   77: 	Q
   78: 	;
   79: 1	; DD
   80: 	S %C=X N %W I %B["P"!(%B["V") N DIE
   81: 	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
   82: 	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
   83: 	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
   84: 	I %B["V" D
   85: 	. N %A,%B,%C,%N,%P,%T,%W
   86: 	. S (DIE,DP)=%B1,DIFLD=%B2,DQ=1
   87: 	. D ^DIE3
   88: 	. S %E=Y'>0 S:Y>0 Y(0)=$P(Y,U,2)
   89: R	D IT:'%E S X=%C
   90: 	Q
   91: IT	D
   92: 	. N %A,%B,%C,%N,%P,%T,%W
   93: 	. I $P(%B3,U,2)["N",$P(%B3,U,5,99)'["$",X?.1"-".N.1".".N S X=+X
   94: 	. X $P(%B3,U,5,99)
   95: 	S %E='$D(X)
   96: 	I '%E,%B'["P" S Y=X
   97: 	I '%E,%B["D" X ^DD("DD") S Y(0)=Y,Y=X
   98: 	Q
   99: 	;
  100: 	;#7001  Yes/No question