DIBTED ;SFISC/GFT-SCREEN-EDIT A SORT TEMPLATE ;03:43 PM 10 Jul 2002 [ 12/09/2003 4:20 PM ]
;;22.0;VA FileMan;**111,1002**;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
DIBTED ;SFISC/GFT-SCREEN-EDIT A SORT TEMPLATE ;03:43 PM 10 Jul 2002 [ 12/09/2003 4:20 PM ]
+1 ;;22.0;VA FileMan;**111,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 NEW DIC,DIBT0,DIBTED,DRK,I,J,DDSCHG
+4 SET DIC=.401
SET DIC(0)="AEQ"
DO ^DIC
IF Y<1
QUIT
+5 SET DIBT0=+Y
DO E
+6 DO PUT
K KILL ^UTILITY("DIBTED",$JOB)
+1 QUIT
+2 ;
EDIT(DIBT0) ; EDIT VIA VA FILEMAN SCREEN EDITOR
+1 NEW DRK,DIBTED,I,J
E NEW 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
+1 XECUTE ^%ZOSF("EON")
+2 IF '$DATA(^DIBT(DIBT0,0))
WRITE !,"NO TEMPLATE SELECTED",!
GOTO K
+3 IF $DATA(^("BY0"))
WRITE !,"CANNOT EDIT A ""BY(0)"" TEMPLATE WITH SCREEN EDITOR",!
HANG 3
GOTO K
+4 SET DIBTED="Sort Template """_$PIECE(^(0),U)_""""
SET (S,DRK)=$PIECE(^(0),U,4)
SET DCC=^DIC(S,0,"GL")
+5 WRITE "..."
+6 DO GET("^TMP(""DIBTED"",$J)")
IF '$DATA(^TMP("DIBTED",$JOB))
Begin DoDot:1
+7 IF '$DATA(^DIBT(+D0,"DIS"))
WRITE !,"NO EDITABLE FIELDS EXIST IN THIS TEMPLATE.",!
+8 WRITE !,"A SEARCH TEMPLATE HAS NO EDITABLE SORT FIELDS.",!
End DoDot:1
HANG 2
GOTO K
+9 SET DIBTH="Editing "_DIBTED
SET DIBTROW=1
DDW DO EDIT^DDW("^TMP(""DIBTED"",$J)","M",DIBTH,"(File "_DRK_")",DIBTROW)
+1 KILL ^UTILITY($JOB,0),^UTILITY("DIBTED",$JOB),I,J,DPP
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL ^TMP("DIBTED",$JOB)
WRITE $CHAR(7),$$EZBLD^DIALOG(8077)
QUIT
+3 SET C=","
SET Q=""""
+4 SET (DV,DNP)=""
SET DE="SORT"
SET (DIL,L)=0
SET (DL,DJ)=1
SET (DI,S)=DRK
+5 DO PROCESS("^TMP(""DIBTED"",$J)")
+6 XECUTE ^%ZOSF("EON")
+7 SET DIBTROW=$ORDER(DIBTEDER(0))
IF DIBTROW
WRITE " ",DIBTEDER(DIBTROW)
HANG 2
SET DIBTH="ERROR! Re-editing "_DIBTED
KILL DIBTEDER
GOTO DDW
+8 KILL ^TMP("DIBTED",$JOB)
+9 SET DDSCHG=1
+10 QUIT
+11 ;
GET(DIBTA) ;put displayable template into @DIBTA
+1 NEW DIBTITLE,DIPR,DIJ,%X,%Y,D,DPP,DIBTAD,DJ,DIPP,DIBTRPT,DIBTOLD,C,X
+2 KILL @DIBTA
+3 SET (DJ,DIBTRPT)=1
SET C=","
SET (X,D0)=DIBT0
SET D="^DIBT("_X_C
+4 DO ENDIPT^DIP11
+5 SET X=""
SET DIBTAD=0
+6 FOR DIJ=0:0
SET DIJ=$ORDER(DPP(DIJ))
IF DIJ=""
QUIT
SET DIPP(DIJ)=DPP(DIJ)
SET %=+DPP(DIJ)
SET DJ=DIJ
DO E1^DIP0
SET %X=0
DO E2^DIP0
+7 KILL DPP,DIJJ
FOR DIJ=0:0
SET DIJ=$ORDER(DIPP(DIJ))
IF DIJ=""
QUIT
Begin DoDot:1
+8 NEW Y,%Y,%
+9 DO NL
+10 SET Y=$PIECE(DIPP(DIJ),U,5)
+11 DO W($SELECT($DATA(DIBTITLE):"WITHIN "_DIBTITLE_", ",DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_$PIECE($PIECE(DIPP(DIJ),U,4),"""",1)_$PIECE(DIPP(DIJ),U,3)_Y)
+12 KILL DIBTITLE
IF $LENGTH(Y,"""")=3
SET DIBTITLE=$$STRIP($PIECE(Y,"""",2))
IF DIBTITLE?.E1":"
SET DIBTITLE=$EXTRACT(DIBTITLE,1,$LENGTH(DIBTITLE)-1)
+13 SET DPP(DIJ)=$PIECE(DIPP(DIJ),U,3)
+14 IF $DATA(^DD(+DIPP(DIJ),+$PIECE(DIPP(DIJ),U,2),0))
SET X=+$PIECE(^(0),U,2)
IF X
IF $DATA(DIPP(DIJ,X))
IF $DATA(^DD(X,0))
DO NL
DO W($PIECE(^DD(X,0),U)_": "_DIPP(DIJ,X))
KILL DIPP(DIJ,X)
+15 FOR %=0:0
SET %=$ORDER(DIPP(DIJ,%))
IF '%
QUIT
IF $DATA(DIPP(DIJ,%))#2
DO NL
DO W($SELECT('$DATA(^DD(%,0,"UP")):$ORDER(^("NM",0))_" ",1:"")_$PIECE(^DD(%,0),U)_": "_DIPP(DIJ,%))
SET DPP(DIJ)=DIPP(DIJ,%)
+16 IF $PIECE(DIPP(DIJ),U,4)["B"
QUIT
+17 DO NL
+18 SET Y=$GET(^DIBT(D0,2,DIJ,"F"))
SET %Y=$PIECE($GET(^("T")),U)
+19 SET %Y=$SELECT(%Y="z":"",$TRANSLATE(%Y," ")="@":"@",1:%Y)
FROMDATE IF Y[".9999"
SET Y=$PIECE(Y,".")+1
IF $PIECE(DIPP(DIJ),U,10)=1
XECUTE ^DD("DD")
+1 SET %=$FIND(Y,"z")
SET X="From: "_$SELECT(%:$EXTRACT(Y,1,%-3)_$CHAR($ASCII(Y,%-2)+1),1:Y)
SET Y=%Y
DO W(X)
+2 DO NL
DO W("To: ")
IF Y]""
IF Y[".9999"
SET Y=Y\1
IF $PIECE(DIPP(DIJ),U,10)=1
Begin DoDot:2
TODATE IF X'?.E1"@"1.NP
SET Y=Y\1
XECUTE ^DD("DD")
End DoDot:2
DO W(Y)
+1 IF $DATA(^DIBT(D0,2,DIJ,"F"))
SET Y=$GET(^("ASK"))
DO NL
DO W($PIECE("Do NOT ask^ASK",U,''Y+1)_" range of values")
End DoDot:1
+2 QUIT
+3 ;
NL SET DIBTAD=DIBTAD+1
SET @DIBTA@(DIBTAD)=$JUSTIFY("",DIJ*3-3)
QUIT
+1 ;
W(X) SET @DIBTA@(DIBTAD)=@DIBTA@(DIBTAD)_X
QUIT
+1 ;
PROCESS(DIBTA) ;puts nodes into ^UTILITY("DIBTED")
+1 NEW DIPP,DIBTMORE,DIBTAB,BY,FR,TO,DIPR,DC,DJ,DK,DIJ,R,ERR,DIBTLINE,DIBTASK,X,A
+2 ;Trick: if 1st Sort Field is screwy, DPP(1) will come back null
KILL DPP
SET DIPP(1)=""
+3 SET DK=DRK
SET DIBTLINE=1
SET DIJ=0
SET DIBTAB=1
SET DC=0
SET DI=^DIC(DK,0,"GL")
SET DNP=""
+4 FOR DJ=1:1
Begin DoDot:1
+5 FOR
SET BY=$$STRIP($PIECE($$LINE,"SORT BY:",2))
IF BY'?.P
QUIT
IF 'DIBTMORE
GOTO Q
+6 SET DIBTEDER=DIBTLINE
SET FR(DJ)=""
SET TO(DJ)=""
+7 FOR
IF DIBTMORE-DIBTAB
QUIT
SET X=$$LINE
IF X'["FIELD
QUIT
SET BY=BY_","_$$STRIP($PIECE(X,"FIELD:",2))
+8 IF DIBTMORE=DIBTAB
SET DIBTLINE=DIBTLINE-1
SET FR(DJ)=$$STRIP($PIECE($$LINE,"From:",2))
+9 IF DIBTMORE=DIBTAB
SET TO(DJ)=$$STRIP($PIECE($$LINE,"To:",2))
+10 IF TO(DJ)]""
IF FR(DJ)=""
SET DIBTMORE=0
SET DIBTEDER(DIBTEDER)="IF YOU HAVE A 'TO' VALUE, YOU MUST HAVE A 'FROM' VALUE"
QUIT
+11 KILL DIBTASK
IF DIBTMORE=DIBTAB
SET DIBTASK=$$UP^DILIBF($$LINE)
+12 DO DJ^DIP
GOODQ ;Does this sort level pass muster?
IF $GET(DJ)
IF $GET(DPP(DJ))]""
Begin DoDot:2
+1 SET DIBTAB=DIBTMORE
+2 IF $GET(DIBTASK)["ASK"
IF DIBTASK'["DON'T"
IF DIBTASK'["NOT"
SET DPP(DJ,"ASK")=1
End DoDot:2
QUIT
+3 SET DIBTMORE=0
SET DIBTEDER(DIBTEDER)=""
Q QUIT
End DoDot:1
IF 'DIBTMORE
QUIT
+1 KILL A
DO DPQ^DIP1
IF $DATA(A(1))
SET DIBTEDER(1)="YOU ARE SORTING BY THE SAME FIELD TWICE"
QUIT
+2 MERGE ^UTILITY("DIBTED",$JOB,"DPP")=DPP
+3 QUIT
+4 ;
LINE() NEW P,X
G SET X=$GET(@DIBTA@(DIBTLINE))
SET DIBTMORE=0
+1 FOR
SET DIBTLINE=DIBTLINE+1
IF '$DATA(^(DIBTLINE))
QUIT
SET P=^(DIBTLINE)
IF P'?.P
Begin DoDot:1
+2 FOR DIBTMORE=1:1
IF $ASCII(P,DIBTMORE)-32
QUIT
End DoDot:1
QUIT
+3 QUIT $$STRIP(X)
+4 ;
STRIP(X) NEW P
FOR P=$LENGTH(X):-1:1
IF $ASCII(X,P)>32
QUIT
SET X=$EXTRACT(X,1,P-1)
B IF $ASCII(X)-32
QUIT X
+1 SET X=$EXTRACT(X,2,999)
GOTO B
+2 ;
PUT ;save template from ^UTILITY
+1 IF '$DATA(^UTILITY("DIBTED",$JOB))
QUIT
+2 NEW DIC
+3 SET DIC("B")=DIBT0
SAVEAS SET DIC=.401
SET DIC("A")="Save revised "_DIBTED_" as: "
SET DIC(0)="AEQL"
SET DIC("S")="I $P(^(0),U,4)=DRK"
+1 DO ^DIC
+2 IF Y<0
QUIT
IF $ORDER(^DIBT(+Y,0))]""
WRITE !,$CHAR(7),"Are you sure you want to overwrite this '",$PIECE(Y,U,2)," 'Template"
SET %=1
DO YN^DICN
IF %-1
IF %<2
QUIT
KILL DIC("B")
GOTO SAVEAS
+3 LOCK +^DIBT(+Y)
+4 SET $PIECE(^DIBT(+Y,0),U,4)=J(0)
+5 LOCK -^DIBT(+Y)
+6 DO SAVEFLDS(+Y)
+7 QUIT
+8 ;
SAVEFLDS(DIBT1) ;
+1 NEW DPP,DIBTOLD
+2 IF '$DATA(^UTILITY("DIBTED",$JOB))!'$GET(DIBT1)
QUIT
NOW DO NOW^%DTC
SET $PIECE(^DIBT(DIBT1,0),U,2)=+$JUSTIFY(%,0,4)
+1 SET $PIECE(^DIBT(DIBT1,0),U,5)=$GET(DUZ)
+2 MERGE DPP=^UTILITY("DIBTED",$JOB,"DPP")
+3 SET DIBTOLD=1
DO SNEW^DIBT
+4 QUIT
