source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIBTED.m@ 1015

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1DIBTED ;SFISC/GFT-SCREEN-EDIT A SORT TEMPLATE ;03:43 PM 10 Jul 2002
2 ;;22.0;VA FileMan;**111**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N DIC,DIBT0,DIBTED,DRK,I,J,DDSCHG
5 S DIC=.401,DIC(0)="AEQ" D ^DIC Q:Y<1
6 S DIBT0=+Y D E
7 D PUT
8K K ^UTILITY("DIBTED",$J)
9 Q
10 ;
11EDIT(DIBT0) ; EDIT VIA VA FILEMAN SCREEN EDITOR
12 N DRK,DIBTED,I,J
13E N DA,DPQ,DM,DP,DPP,D0,DIBTEDER,DIBTH,L,N,BY,DE,Y,DIBTX,Q,DIBTROW,DCL,DXS,DHD,DIJJ,DDH,DI,DV,DJ,DL,DK,DIL,DU,P,DNP,DIPP,G,S,C,Q,B,DIPA,DCC
14 X ^%ZOSF("EON")
15 I '$D(^DIBT(DIBT0,0)) W !,"NO TEMPLATE SELECTED",! G K
16 I $D(^("BY0")) W !,"CANNOT EDIT A ""BY(0)"" TEMPLATE WITH SCREEN EDITOR",! H 3 G K
17 S DIBTED="Sort Template """_$P(^(0),U)_"""",(S,DRK)=$P(^(0),U,4),DCC=^DIC(S,0,"GL")
18 W "..."
19 D GET("^TMP(""DIBTED"",$J)") I '$D(^TMP("DIBTED",$J)) D H 2 G K
20 . I '$D(^DIBT(+D0,"DIS")) W !,"NO EDITABLE FIELDS EXIST IN THIS TEMPLATE.",!
21 . W !,"A SEARCH TEMPLATE HAS NO EDITABLE SORT FIELDS.",!
22 S DIBTH="Editing "_DIBTED,DIBTROW=1
23DDW D EDIT^DDW("^TMP(""DIBTED"",$J)","M",DIBTH,"(File "_DRK_")",DIBTROW)
24 K ^UTILITY($J,0),^UTILITY("DIBTED",$J),I,J,DPP
25 I $D(DUOUT)!$D(DTOUT) K ^TMP("DIBTED",$J) W $C(7),$$EZBLD^DIALOG(8077) Q
26 S C=",",Q=""""
27 S (DV,DNP)="",DE="SORT",(DIL,L)=0,(DL,DJ)=1,(DI,S)=DRK
28 D PROCESS("^TMP(""DIBTED"",$J)")
29 X ^%ZOSF("EON")
30 S DIBTROW=$O(DIBTEDER(0)) I DIBTROW W " ",DIBTEDER(DIBTROW) H 2 S DIBTH="ERROR! Re-editing "_DIBTED K DIBTEDER G DDW
31 K ^TMP("DIBTED",$J)
32 S DDSCHG=1
33 Q
34 ;
35GET(DIBTA) ;put displayable template into @DIBTA
36 N DIBTITLE,DIPR,DIJ,%X,%Y,D,DPP,DIBTAD,DJ,DIPP,DIBTRPT,DIBTOLD,C,X
37 K @DIBTA
38 S (DJ,DIBTRPT)=1,C=",",(X,D0)=DIBT0,D="^DIBT("_X_C
39 D ENDIPT^DIP11
40 S X="",DIBTAD=0
41 F DIJ=0:0 S DIJ=$O(DPP(DIJ)) Q:DIJ="" S DIPP(DIJ)=DPP(DIJ),%=+DPP(DIJ),DJ=DIJ D E1^DIP0 S %X=0 D E2^DIP0
42 K DPP,DIJJ F DIJ=0:0 S DIJ=$O(DIPP(DIJ)) Q:DIJ="" D
43 .N Y,%Y,%
44 .D NL
45 .S Y=$P(DIPP(DIJ),U,5)
46 .D W($S($D(DIBTITLE):"WITHIN "_DIBTITLE_", ",DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_$P($P(DIPP(DIJ),U,4),"""",1)_$P(DIPP(DIJ),U,3)_Y)
47 .K DIBTITLE I $L(Y,"""")=3 S DIBTITLE=$$STRIP($P(Y,"""",2)) I DIBTITLE?.E1":" S DIBTITLE=$E(DIBTITLE,1,$L(DIBTITLE)-1)
48 .S DPP(DIJ)=$P(DIPP(DIJ),U,3)
49 .I $D(^DD(+DIPP(DIJ),+$P(DIPP(DIJ),U,2),0)) S X=+$P(^(0),U,2) I X,$D(DIPP(DIJ,X)),$D(^DD(X,0)) D NL,W($P(^DD(X,0),U)_": "_DIPP(DIJ,X)) K DIPP(DIJ,X)
50 .F %=0:0 S %=$O(DIPP(DIJ,%)) Q:'% I $D(DIPP(DIJ,%))#2 D NL,W($S('$D(^DD(%,0,"UP")):$O(^("NM",0))_" ",1:"")_$P(^DD(%,0),U)_": "_DIPP(DIJ,%)) S DPP(DIJ)=DIPP(DIJ,%)
51 .Q:$P(DIPP(DIJ),U,4)["B"
52 .D NL
53 .S Y=$G(^DIBT(D0,2,DIJ,"F")),%Y=$P($G(^("T")),U)
54 .S %Y=$S(%Y="z":"",$TR(%Y," ")="@":"@",1:%Y)
55FROMDATE .S:Y[".9999" Y=$P(Y,".")+1 X:$P(DIPP(DIJ),U,10)=1 ^DD("DD")
56 .S %=$F(Y,"z"),X="From: "_$S(%:$E(Y,1,%-3)_$C($A(Y,%-2)+1),1:Y),Y=%Y D W(X)
57 .D NL,W("To: ") I Y]"" S:Y[".9999" Y=Y\1 D:$P(DIPP(DIJ),U,10)=1 D W(Y)
58TODATE ..S:X'?.E1"@"1.NP Y=Y\1 X ^DD("DD")
59 .I $D(^DIBT(D0,2,DIJ,"F")) S Y=$G(^("ASK")) D NL,W($P("Do NOT ask^ASK",U,''Y+1)_" range of values")
60 Q
61 ;
62NL S DIBTAD=DIBTAD+1,@DIBTA@(DIBTAD)=$J("",DIJ*3-3) Q
63 ;
64W(X) S @DIBTA@(DIBTAD)=@DIBTA@(DIBTAD)_X Q
65 ;
66PROCESS(DIBTA) ;puts nodes into ^UTILITY("DIBTED")
67 N DIPP,DIBTMORE,DIBTAB,BY,FR,TO,DIPR,DC,DJ,DK,DIJ,R,ERR,DIBTLINE,DIBTASK,X,A
68 K DPP S DIPP(1)="" ;Trick: if 1st Sort Field is screwy, DPP(1) will come back null
69 S DK=DRK,DIBTLINE=1,DIJ=0,DIBTAB=1,DC=0,DI=^DIC(DK,0,"GL"),DNP=""
70 F DJ=1:1 D Q:'DIBTMORE
71 .F S BY=$$STRIP($P($$LINE,"SORT BY:",2)) Q:BY'?.P G Q:'DIBTMORE
72 .S DIBTEDER=DIBTLINE,FR(DJ)="",TO(DJ)=""
73 .F Q:DIBTMORE-DIBTAB S X=$$LINE Q:X'["FIELD: " S BY=BY_","_$$STRIP($P(X,"FIELD:",2))
74 .I DIBTMORE=DIBTAB S DIBTLINE=DIBTLINE-1,FR(DJ)=$$STRIP($P($$LINE,"From:",2))
75 .I DIBTMORE=DIBTAB S TO(DJ)=$$STRIP($P($$LINE,"To:",2))
76 .I TO(DJ)]"",FR(DJ)="" S DIBTMORE=0,DIBTEDER(DIBTEDER)="IF YOU HAVE A 'TO' VALUE, YOU MUST HAVE A 'FROM' VALUE" Q
77 .K DIBTASK I DIBTMORE=DIBTAB S DIBTASK=$$UP^DILIBF($$LINE)
78 .D DJ^DIP
79GOODQ .I $G(DJ),$G(DPP(DJ))]"" D Q ;Does this sort level pass muster?
80 ..S DIBTAB=DIBTMORE
81 ..I $G(DIBTASK)["ASK",DIBTASK'["DON'T",DIBTASK'["NOT" S DPP(DJ,"ASK")=1
82 .S DIBTMORE=0,DIBTEDER(DIBTEDER)=""
83Q .Q
84 K A D DPQ^DIP1 I $D(A(1)) S DIBTEDER(1)="YOU ARE SORTING BY THE SAME FIELD TWICE" Q
85 M ^UTILITY("DIBTED",$J,"DPP")=DPP
86 Q
87 ;
88LINE() N P,X
89G S X=$G(@DIBTA@(DIBTLINE)),DIBTMORE=0
90 F S DIBTLINE=DIBTLINE+1 Q:'$D(^(DIBTLINE)) S P=^(DIBTLINE) I P'?.P D Q
91 .F DIBTMORE=1:1 Q:$A(P,DIBTMORE)-32
92 Q $$STRIP(X)
93 ;
94STRIP(X) N P F P=$L(X):-1:1 Q:$A(X,P)>32 S X=$E(X,1,P-1)
95B I $A(X)-32 Q X
96 S X=$E(X,2,999) G B
97 ;
98PUT ;save template from ^UTILITY
99 I '$D(^UTILITY("DIBTED",$J)) Q
100 N DIC
101 S DIC("B")=DIBT0
102SAVEAS S DIC=.401,DIC("A")="Save revised "_DIBTED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK"
103 D ^DIC
104 Q:Y<0 I $O(^DIBT(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS
105 L +^DIBT(+Y)
106 S $P(^DIBT(+Y,0),U,4)=J(0)
107 L -^DIBT(+Y)
108 D SAVEFLDS(+Y)
109 Q
110 ;
111SAVEFLDS(DIBT1) ;
112 N DPP,DIBTOLD
113 Q:'$D(^UTILITY("DIBTED",$J))!'$G(DIBT1)
114NOW D NOW^%DTC S $P(^DIBT(DIBT1,0),U,2)=+$J(%,0,4)
115 S $P(^DIBT(DIBT1,0),U,5)=$G(DUZ)
116 M DPP=^UTILITY("DIBTED",$J,"DPP")
117 S DIBTOLD=1 D SNEW^DIBT
118 Q
Note: See TracBrowser for help on using the repository browser.