Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIBTED

DIBTED.m

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