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

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1DIFROM41 ;SFISC/XAK-CREATES 'INIT3' (CONT.) ;11:02 AM 13 Sep 1994
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S L=0 F DD=DD:1 S L=L+1,X=$T(TXT+L) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999)
5 Q
6TXT ;
7 ;;DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
8 ;; E S DISYS=^DD("OS")
9 ;; Q:'$D(^DD("OS",DISYS,"ZS"))
10 ;; S DIFR1=""
11 ;;DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
12 ;; F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
13 ;; G DZ1
14 ;; ;
15 ;;OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
16 ;; W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
17 ;; I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
18 ;; S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
19 ;; S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
20 ;; D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
21 ;; F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
22 ;; S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
23 ;; ;
24 ;;ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
25 ;;Q Q
26 ;;A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0))
27 ;; K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
28 ;; I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%)
29 ;; I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D
30 ;; .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
31 ;; .Q
32 ;; I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
33 ;; I N="DIST(.403," D BLK
34 ;; S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
35 ;; D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
36 ;; I N="DIST(.403," D
37 ;; .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA)
38 ;; .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q
39 ;; .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled"
40 ;; .Q
41 ;; Q
42 ;;BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
43 ;; K A0,A1,A2,J,L Q
44 ;;B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D
45 ;; .N X S X=0
46 ;; .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X)
47 ;; .Q
48 ;; S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
49 ;; F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D
50 ;; .N X S X=0
51 ;; .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X)
52 ;; .Q
53 ;; S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
54 ;; Q
55 ;;KAD(D0) N D1,X
56 ;; S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1)
57 ;; Q
Note: See TracBrowser for help on using the repository browser.