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

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

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;06:20 PM 2 Apr 2001
2 ;;22.0;VA FileMan;**82**;Nov 17, 1998
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4MENU ;
50 ; select and edit templates, until user quits
6 S DIC="^DOPT(""DIBT"",",DICF=DI
7 I '$D(^DOPT("DIBT",.402)) S ^(0)="TEMPLATE FILE^1.01" K ^("B") D
8 .F X=.4,.401,.402 S ^DOPT("DIBT",X,0)=$P(^DIC(X,0),U)
9 .N DIK S DIK=DIC D IXALL^DIK
10 S DIC(0)="FQEAIN",DIC("A")="Select TEMPLATE File: "
11 S DIC("S")="I Y=.4!(Y=.401)!(Y=.402)"
12 D ^DIC K DIC Q:Y<0
13 K DTOUT F Q:'$$T(+Y,DICF) I $D(DTOUT) K DTOUT Q
14 Q
15 ;
16T(DDSFILE,DICF) ;=.4,.401,.402
17 N Y,DIC,DIERR,DDSPARM,DR,DA,DIN
18 W !! S DIC=DDSFILE,DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF
19 S DIC(0)="AEQI" D IX^DIC I Y<0 Q 0
20 S DA=+Y I '$$SCREEN G SCROLL
21 S DIN=$S(DDSFILE=.4:"DIPTED",DDSFILE=.402:"DIETED",1:"DIBTED")
22 S DR="["_DIN_"]",DDSPARM="E" D ^DDS I '$D(DIERR) Q 1
23SCROLL N DIE,DIOVRD,DR
24 S DIE=DDSFILE,DR=".01:3;5:7;10;707;491620",DIOVRD=1 D ^DIE Q 1
25 ;
26SCREEN(HELP) ;
27 N DIR,DIRUT,DUOUT,X,Y,DIERR
28 K DUZ("SCREEN") ;COMMENT OUT THIS LINE IF YOU WANT FILEMAN TO REMEMBER!
29 I $G(DUZ("SCREEN"))=0 Q 0
30 D SET^DDGLIB0 I $D(DIERR) Q 0
31 I '$G(DUZ("SCREEN")) D
32 .S DIR(0)="Y",DIR("A")="Do you want to use the screen-mode version",DIR("B")="YES"
33 .I $D(HELP) S DIR("?")=HELP
34 .D ^DIR I Y-1 S:Y=0 DUZ("SCREEN")=0 Q
35 .S DUZ("SCREEN")=1
36 D KILL^DDGLIB0()
37 I ^DD("OS")=9 U $I:VT=1 ;FOR DATATREE
38 Q +$G(DUZ("SCREEN"))
39 ;
40S ;
41 D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT))
42 G N:X="",S:Y<0
43 S DIBT1=+Y
44SNEW K ^DIBT(DIBT1,2),^("BY0"),^("BY0D") S $P(^DIBT(DIBT1,0),U,7)=DT
45 I $G(BY(0))]"",$D(DPP(0)) D
46 . N DIBY,DIREC,%,I,D,F,T,Q1,Q2,O S %=DIBT1_"," S DIBY(.401,%,1622)=$P(BY(0),U,2),DIBY(.401,%,1623)=DPP(0)+1 D FILE^DIE("E","DIBY")
47 . F I=1:1:DPP(0) D
48 .. S F=$P($G(DPP(I,"F")),U,2),T=$P($G(DPP(I,"T")),U,2),O=$P($G(DPP(I)),U,4),Q1="" S:O["!" Q1=Q1_"!" S:O["#" Q1=Q1_"#" S Q2=$P($G(DPP(I)),U,5),O=$G(DPP(I,"OUT"))
49 .. S %="+"_I_","_DIBT1_"," K DIBY(.4011624,%)
50 .. S:F]"" DIBY(.4011624,%,1)=F S:T]"" DIBY(.4011624,%,2)=T S:Q1]"" DIBY(.4011624,%,3.1)=Q1 S:Q2]"" DIBY(.4011624,%,3.2)=Q2 S:O]"" DIBY(.4011624,%,4)=O
51 .. Q:'$D(DIBY(.4011624,%)) S DIBY(.4011624,%,.01)=I,DIREC(I)=I Q
52 . D UPDATE^DIE("E","DIBY","DIREC")
53 . Q
54 S (DIBT2,DIBT3)=+$G(DPP(0)) F S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3 S DIBT2=DIBT2+1 D
55 .N DIC,DA,DIE,DINUM,DIOVRD,DR,DO S X=$P(DPP(DIBT3),U) Q:+$P(X,"E")'=X S DIC="^DIBT("_DIBT1_",2,",DIC(0)="L",DA(1)=DIBT1,DINUM=DIBT2,DIOVRD=1,DIC("P")=$P(^DD(.401,1621,0),U,2) D FILE^DICN K DIC,DA,DINUM,DIOVRD
56 .N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10)
57 .S A="A" F S A=$O(DPP(DIBT3,A)) Q:A="" S %=$G(DPP(DIBT3,A)) S:%]"" ^DIBT(DIBT1,2,DIBT2,A)=%
58 .S (C,D)=0 F A=-1:0 S A=$O(DPP(DIBT3,A)) Q:+$P(A,"E")'=A D
59 ..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM
60 ..S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S D=D+1,%=2,%(1)=18,X=A,DINUM=D D DICM S:Y>0 ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$P(DPP(DIBT3,A,B),U,4,99)
61 ..Q
62 .S D=0,A="OV" F S A=$O(DPP(DIBT3,A)) Q:$E(A,1,2)'="OV" S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S C=$G(DPP(DIBT3,A,B)) I C]"" S D=D+1,%=3,%(1)=19,X=A,DINUM=D D DICM I Y>0 S $P(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B,^("OVF0")=C
63 .Q
64 I $D(DIBTOLD) K DIBTOLD D K Q
65 S DIBT2=+$G(DPP(0))
66S0 S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B"
67 S DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and",DIR("?")="ending sort values when the print job is run."
68 W ! S DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$P(DPP(DIBT2),U,3)_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) D K G Q^DIP
69 G:Y=0 S0
70S1 S ^DIBT(DIBT1,2,DIBT2,"ASK")=1
71 G S0
72 ;
73DICM S DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_",",DA(2)=DIBT1,DA(1)=DIBT2,DIC(0)="L",DIOVRD=1,DIC("P")=$P(^DD(.4014,%(1),0),U,2)
74 N C,D
75 I %(1)=18 S DIC("DR")="1////"_B F C=1,2,3 S D=$P(DPP(DIBT3,A,B),U,C) I D]"" S DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D
76 N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q
77 ;
78US S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q
79 N % F X=+$G(DPP(0)):0 S X=$O(DPP(X)) Q:'X D
80 . F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT" K ^DIBT(DIBT1,2,X,%) I $G(DPP(X,%))]"" S:%'="SER" ^DIBT(DIBT1,2,X,%)=DPP(X,%)
81 . Q
82 Q
83 ;
84K K DIEDT,DIBT2,DIBT3 Q
85N D K G N^DIP1
Note: See TracBrowser for help on using the repository browser.