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

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