source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIR1.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1DIR1 ;SFISC/XAK-READER-MAID (PROCESS DATATYPE) ;11:41 AM 8 Jun 2007
2 ;;22.0;VA FileMan;**1,5,73,156**;Mar 30, 1999;Build 1
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 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")
5 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
7Y ; YES/NO
8S ; SET
9 N %BU,%K,%M,%J,DDH
10 I $L(X)>245 S %E=1,Y="" Q ;DI*156
11 I %T="S",$D(DIR("S"))#2 S DIC("S")=DIR("S")
12 S %BA=$S($D(DIC("S")):DIC("S"),1:"I 1")
13 S (%J,%K,DDH)=0
14 I %B'[":",$O(DIR("C",""))]"" D
15 . ;Look for match on internal code
16 . 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
17 . ;If not found, look for match on external code
18 . 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
19 . ;If still no match, convert X and choices to uppercase, search again
20 . I %I="",%A'["X",'%K D
21 .. S %M=X N X S X=$$UP^DILIBF(%M)
22 .. 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
23 .. 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
24 . S %J=%I
25 E D
26 . S Y(0)=$P($P(";"_%B,";"_X_":",2),";") I Y(0)]"" S Y=X X %BA I S %J=1
27 . 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
28 . I %J="",%A'["X",'%K D
29 .. S %BU=$$UP^DILIBF(%B),%M=X N X S X=$$UP^DILIBF(%M)
30 .. S Y=$F(";"_%BU,";"_X_":") I Y D X %BA I S %J=1 Q
31 ... S Y(0)=$P($E(";"_%B,Y,999),";")
32 ... S Y=$L($E(";"_%B,1,Y-1),";"),Y=$P($P(";"_%B,";",Y),":")
33 .. 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
34 I %K=1 S Y=$P(%K(1),":"),Y(0)=$P(%K(1),":",2)
35 I %K>1,$G(DIQUIET) S %E=1 Q
36 I %K>1 D CH Q:%E=1 I '$D(%K(%I)) S X=%I G S
37 I %J="",'%K S %E=1 Q
38 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))
39 I %T="Y" S (%,Y)=+$$PRS^DIALOGU(7001,$E(X)) S:%<0 (%,Y)="" S:%=2 Y=0
40 Q
41 ;
42CH ;
43 N DIY,DDD,DDC,DS,DD
44 F %I=1:1:%K S A0=" "_%I_" "_$P(%K(%I),":",2) D MSG
45 I '$D(DDS) S A0="Choose 1-"_%K_": " D MSG R %I:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME)
46 I $D(DDS) S DDD=2,DDC=5,(DS,DD)=%K D LIST^DDSU S %I=DIY
47 I U[%I!(%I?1."?") S X="?",%E=1 Q
48 I $D(%K(%I)) S Y=$P(%K(%I),":"),Y(0)=$P(%K(%I),":",2)
49 Q
50 ;
51MSG ;
52 I $D(DDS),A0]"" S DDH=$G(DDH)+1,DS(DDH)=$P(%K(%I),":"),DDH(DDH,DDH)=$P(%K(%I),":",2)
53 I '$D(DDS) W !,A0
54 K A0
55 Q
56 ;
57L ; LIST OR RANGE
58 D L^DIR3
59 Q
60D ; DATE
61 D ^%DT I Y<0 S %E=1 Q
62 I %D1["NOW"!(%D2["NOW")&($P("NOW",$$UP^DILIBF(X))="") S:%D1["NOW" %B1=Y S:%D2["NOW" %B2=Y
63 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
64 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))
65 S Y(1)=Y X ^DD("DD") S Y(0)=Y,Y=Y(1) K Y(1)
66 Q
67 ;
68N ; NUMERIC
69 I $L($P(X,"."))>24 S %E=1 Q
70 I X'?.1"-".N.1".".N S %E=1 Q
71 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
72 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
73 S Y=+X
74 Q
75 ;
76F ; FREETEXT
77 S Y=X I X[U,%A'["U" S %E=1
78 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:"")
79 I $L(X)<%B1!($L(X)>%B2) S %E=1
80 Q
81 ;
82E ; END-OF-PAGE
83 S Y=X="" S:X=U (DUOUT,DIRUT)=1 I $L(X),X'=U S %E=1
84 Q
85 ;
86P ; POINTER
87 S:'$D(DDS) %B2=$P(%B2,"L")_$P(%B2,"L",2)
88 I %B2["A" S %B2=$P(%B2,"A")_$P(%B2,"A",2)
89 S:$D(DIR("S"))#2 DIC("S")=DIR("S")
90 S DIC=%B1,DIC(0)=%B2,%C=X D P1
91 I $D(X)#2,X="",Y<0 S %E=-1
92 E S %E=Y<0
93 S X=%C
94 Q
95P1 N %A,%B,%C,%N,%P,%T,%W D ^DIC
96 Q
97 ;
981 ; DD
99 S %C=X N %W I %B["P"!(%B["V") N DIE
100 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
101 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
102 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
103 I %B["V" D
104 . N %A,%B,%C,%N,%P,%T,%W
105 . S (DIE,DP)=%B1,DIFLD=%B2,DQ=1
106 . D ^DIE3
107 . S %E=Y'>0 S:Y>0 Y(0)=$P(Y,U,2)
108R D IT:'%E S X=%C
109 Q
110IT D
111 . N %A,%B,%C,%N,%P,%T,%W N:'$G(DIRDINUM) DINUM
112 . 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
113 . X $P(%B3,U,5,99)
114 S %E='$D(X)
115 I '%E,%B'["P" S Y=X
116 I '%E,%B["D" X ^DD("DD") S Y(0)=Y,Y=X
117 Q
118 ;
119 ;#7001 Yes/No question
Note: See TracBrowser for help on using the repository browser.