119 lines
5.1 KiB
Mathematica
119 lines
5.1 KiB
Mathematica
DIBTED ;SFISC/GFT-SCREEN-EDIT A SORT TEMPLATE ;03:43 PM 10 Jul 2002
|
|
;;22.0;VA FileMan;**111**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
N DIC,DIBT0,DIBTED,DRK,I,J,DDSCHG
|
|
S DIC=.401,DIC(0)="AEQ" D ^DIC Q:Y<1
|
|
S DIBT0=+Y D E
|
|
D PUT
|
|
K K ^UTILITY("DIBTED",$J)
|
|
Q
|
|
;
|
|
EDIT(DIBT0) ; EDIT VIA VA FILEMAN SCREEN EDITOR
|
|
N DRK,DIBTED,I,J
|
|
E 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
|
|
X ^%ZOSF("EON")
|
|
I '$D(^DIBT(DIBT0,0)) W !,"NO TEMPLATE SELECTED",! G K
|
|
I $D(^("BY0")) W !,"CANNOT EDIT A ""BY(0)"" TEMPLATE WITH SCREEN EDITOR",! H 3 G K
|
|
S DIBTED="Sort Template """_$P(^(0),U)_"""",(S,DRK)=$P(^(0),U,4),DCC=^DIC(S,0,"GL")
|
|
W "..."
|
|
D GET("^TMP(""DIBTED"",$J)") I '$D(^TMP("DIBTED",$J)) D H 2 G K
|
|
. I '$D(^DIBT(+D0,"DIS")) W !,"NO EDITABLE FIELDS EXIST IN THIS TEMPLATE.",!
|
|
. W !,"A SEARCH TEMPLATE HAS NO EDITABLE SORT FIELDS.",!
|
|
S DIBTH="Editing "_DIBTED,DIBTROW=1
|
|
DDW D EDIT^DDW("^TMP(""DIBTED"",$J)","M",DIBTH,"(File "_DRK_")",DIBTROW)
|
|
K ^UTILITY($J,0),^UTILITY("DIBTED",$J),I,J,DPP
|
|
I $D(DUOUT)!$D(DTOUT) K ^TMP("DIBTED",$J) W $C(7),$$EZBLD^DIALOG(8077) Q
|
|
S C=",",Q=""""
|
|
S (DV,DNP)="",DE="SORT",(DIL,L)=0,(DL,DJ)=1,(DI,S)=DRK
|
|
D PROCESS("^TMP(""DIBTED"",$J)")
|
|
X ^%ZOSF("EON")
|
|
S DIBTROW=$O(DIBTEDER(0)) I DIBTROW W " ",DIBTEDER(DIBTROW) H 2 S DIBTH="ERROR! Re-editing "_DIBTED K DIBTEDER G DDW
|
|
K ^TMP("DIBTED",$J)
|
|
S DDSCHG=1
|
|
Q
|
|
;
|
|
GET(DIBTA) ;put displayable template into @DIBTA
|
|
N DIBTITLE,DIPR,DIJ,%X,%Y,D,DPP,DIBTAD,DJ,DIPP,DIBTRPT,DIBTOLD,C,X
|
|
K @DIBTA
|
|
S (DJ,DIBTRPT)=1,C=",",(X,D0)=DIBT0,D="^DIBT("_X_C
|
|
D ENDIPT^DIP11
|
|
S X="",DIBTAD=0
|
|
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
|
|
K DPP,DIJJ F DIJ=0:0 S DIJ=$O(DIPP(DIJ)) Q:DIJ="" D
|
|
.N Y,%Y,%
|
|
.D NL
|
|
.S Y=$P(DIPP(DIJ),U,5)
|
|
.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)
|
|
.K DIBTITLE I $L(Y,"""")=3 S DIBTITLE=$$STRIP($P(Y,"""",2)) I DIBTITLE?.E1":" S DIBTITLE=$E(DIBTITLE,1,$L(DIBTITLE)-1)
|
|
.S DPP(DIJ)=$P(DIPP(DIJ),U,3)
|
|
.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)
|
|
.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,%)
|
|
.Q:$P(DIPP(DIJ),U,4)["B"
|
|
.D NL
|
|
.S Y=$G(^DIBT(D0,2,DIJ,"F")),%Y=$P($G(^("T")),U)
|
|
.S %Y=$S(%Y="z":"",$TR(%Y," ")="@":"@",1:%Y)
|
|
FROMDATE .S:Y[".9999" Y=$P(Y,".")+1 X:$P(DIPP(DIJ),U,10)=1 ^DD("DD")
|
|
.S %=$F(Y,"z"),X="From: "_$S(%:$E(Y,1,%-3)_$C($A(Y,%-2)+1),1:Y),Y=%Y D W(X)
|
|
.D NL,W("To: ") I Y]"" S:Y[".9999" Y=Y\1 D:$P(DIPP(DIJ),U,10)=1 D W(Y)
|
|
TODATE ..S:X'?.E1"@"1.NP Y=Y\1 X ^DD("DD")
|
|
.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")
|
|
Q
|
|
;
|
|
NL S DIBTAD=DIBTAD+1,@DIBTA@(DIBTAD)=$J("",DIJ*3-3) Q
|
|
;
|
|
W(X) S @DIBTA@(DIBTAD)=@DIBTA@(DIBTAD)_X Q
|
|
;
|
|
PROCESS(DIBTA) ;puts nodes into ^UTILITY("DIBTED")
|
|
N DIPP,DIBTMORE,DIBTAB,BY,FR,TO,DIPR,DC,DJ,DK,DIJ,R,ERR,DIBTLINE,DIBTASK,X,A
|
|
K DPP S DIPP(1)="" ;Trick: if 1st Sort Field is screwy, DPP(1) will come back null
|
|
S DK=DRK,DIBTLINE=1,DIJ=0,DIBTAB=1,DC=0,DI=^DIC(DK,0,"GL"),DNP=""
|
|
F DJ=1:1 D Q:'DIBTMORE
|
|
.F S BY=$$STRIP($P($$LINE,"SORT BY:",2)) Q:BY'?.P G Q:'DIBTMORE
|
|
.S DIBTEDER=DIBTLINE,FR(DJ)="",TO(DJ)=""
|
|
.F Q:DIBTMORE-DIBTAB S X=$$LINE Q:X'["FIELD: " S BY=BY_","_$$STRIP($P(X,"FIELD:",2))
|
|
.I DIBTMORE=DIBTAB S DIBTLINE=DIBTLINE-1,FR(DJ)=$$STRIP($P($$LINE,"From:",2))
|
|
.I DIBTMORE=DIBTAB S TO(DJ)=$$STRIP($P($$LINE,"To:",2))
|
|
.I TO(DJ)]"",FR(DJ)="" S DIBTMORE=0,DIBTEDER(DIBTEDER)="IF YOU HAVE A 'TO' VALUE, YOU MUST HAVE A 'FROM' VALUE" Q
|
|
.K DIBTASK I DIBTMORE=DIBTAB S DIBTASK=$$UP^DILIBF($$LINE)
|
|
.D DJ^DIP
|
|
GOODQ .I $G(DJ),$G(DPP(DJ))]"" D Q ;Does this sort level pass muster?
|
|
..S DIBTAB=DIBTMORE
|
|
..I $G(DIBTASK)["ASK",DIBTASK'["DON'T",DIBTASK'["NOT" S DPP(DJ,"ASK")=1
|
|
.S DIBTMORE=0,DIBTEDER(DIBTEDER)=""
|
|
Q .Q
|
|
K A D DPQ^DIP1 I $D(A(1)) S DIBTEDER(1)="YOU ARE SORTING BY THE SAME FIELD TWICE" Q
|
|
M ^UTILITY("DIBTED",$J,"DPP")=DPP
|
|
Q
|
|
;
|
|
LINE() N P,X
|
|
G S X=$G(@DIBTA@(DIBTLINE)),DIBTMORE=0
|
|
F S DIBTLINE=DIBTLINE+1 Q:'$D(^(DIBTLINE)) S P=^(DIBTLINE) I P'?.P D Q
|
|
.F DIBTMORE=1:1 Q:$A(P,DIBTMORE)-32
|
|
Q $$STRIP(X)
|
|
;
|
|
STRIP(X) N P F P=$L(X):-1:1 Q:$A(X,P)>32 S X=$E(X,1,P-1)
|
|
B I $A(X)-32 Q X
|
|
S X=$E(X,2,999) G B
|
|
;
|
|
PUT ;save template from ^UTILITY
|
|
I '$D(^UTILITY("DIBTED",$J)) Q
|
|
N DIC
|
|
S DIC("B")=DIBT0
|
|
SAVEAS S DIC=.401,DIC("A")="Save revised "_DIBTED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK"
|
|
D ^DIC
|
|
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
|
|
L +^DIBT(+Y)
|
|
S $P(^DIBT(+Y,0),U,4)=J(0)
|
|
L -^DIBT(+Y)
|
|
D SAVEFLDS(+Y)
|
|
Q
|
|
;
|
|
SAVEFLDS(DIBT1) ;
|
|
N DPP,DIBTOLD
|
|
Q:'$D(^UTILITY("DIBTED",$J))!'$G(DIBT1)
|
|
NOW D NOW^%DTC S $P(^DIBT(DIBT1,0),U,2)=+$J(%,0,4)
|
|
S $P(^DIBT(DIBT1,0),U,5)=$G(DUZ)
|
|
M DPP=^UTILITY("DIBTED",$J,"DPP")
|
|
S DIBTOLD=1 D SNEW^DIBT
|
|
Q
|