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

DIP.m

Go to the documentation of this file. 
  1. DIP ;SFISC/XAK,TKW-GET SORT SPECS ;11:10 AM  17 May 2002 [ 12/09/2003  4:16 PM ]
  1.  ;;22.0;VA FileMan;**2,64,97,1002**;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  K %ZIS,BY,FLDS,DX,DIS,DISV,DHIT,DTOUT,DIFF D ^DICRW G Q:$D(DTOUT),EN:$D(DIC)
  1. Q K DIJ,DIOEND,DIOBEG,DISTOP,DISTXT,DI,DICS,DJ,BY,A,DICSS,ZTSK,FR,TO,FLDS,DHD,DHIT,DIS,PG,DCOPIES,L,DISUPNO,DIPCRIT,DCC,DNP
  1.  K %,%H,%I,%X,%Y,%DT,B,D0,DD,DIAC,DIFILE,DM,DP,DQ S I=$G(X) K X S:I]"" X=I
  1.  D CLEAN^DIEFU
  1. QQ K DIPR,DIBT,DIBT1,DIBT2,DIBTOLD,DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,DITYP,DINS,DIPT,DISX
  1.  K S,DC,DL,DV,DE,DA,DK,DIFF,Y,R,C,D,I,J,Q,M,P,N,Q S:$D(DID) M=U Q
  1.  ;
  1. INIT S DIQUIET=1 Q:$D(ZTQUEUED)  I L!('$D(FLDS)#2)!($D(DIASKHD))!($G(IOP)="") K DIQUIET Q
  1.  I $G(BY)="" K:$G(BY(0))="" DIQUIET Q
  1.  N I,X F I=1:1 Q:'$G(DIQUIET)  S X=$P(BY,",",I) Q:X=""  K:X="@" DIQUIET D:$G(DIQUIET)
  1.  . I $D(FR)#2 K:$P(FR,",",I)="?" DIQUIET I '$D(TO)#2 K DIQUIET Q
  1.  . I $D(TO)#2 K:$P(TO,",",I)="?"!('$D(FR)#2) DIQUIET Q
  1.  . I '$D(FR(I))#2!($G(FR(I))="?") K DIQUIET Q
  1.  . I '$D(TO(I))#2!($G(TO(I))="?") K DIQUIET
  1.  . Q
  1.  Q
  1.  ;
  1. EN S L=1 N DIERR
  1. EN1 ;
  1.  S:DIC DIC=$G(^DIC(DIC,0,"GL")) G Q:DIC=""
  1.  I "^DIA(^DDA("[$E(DIC,1,5),'$G(DIA) S DIA=+$P(DIC,"(",2) G Q:'DIA
  1.  S:$D(L)[0 L=0 N DIFM S DIFM=+L N DIFMSTOP D CLEAN^DIEFU I '$D(DIQUIET) N DIQUIET D INIT
  1.  S DJ=1,U="^",(DCC,DI)=DIC,DNP="" D QQ I '$D(DISYS) N DISYS D OS^DII
  1.  I $G(BY)="@" S %=$G(BY(0)),DNP=BY K BY S:%]"" BY(0)=% K %
  1.  S:'$D(DTIME) DTIME=300
  1. I ;
  1.  G Q:'$D(@(DI_"0)")) S S=+$P(^(0),U,2)
  1.  S Q="""",C=",",DC=0,DIJ=0,DE=$S(L=0!L!(L="]"):"SORT",1:L),DIL(S)=U
  1.  I $D(BY(0)) D EN^DIP10 G Q:'$D(BY(0)) I $G(BY)="" S DPP=DPP(0) G N^DIP1
  1. LEVELS F DJ=DJ:1 D DJ Q:$G(X)=""!($D(DTOUT))!($D(DUOUT))!'$D(DJ)  G FTEM^DIP1:X?1"[".E
  1.  I $D(DUOUT)!($D(DTOUT))!('$D(DJ)) G Q
  1.  G DUP^DIP1
  1. DJ K DPP(DJ),DL,DV,I,J S I(0)=DI,(DL,J(0))=S,(N,DU)=0,Y=.01
  1.  ;I DJ>1 S DIPR=$S($D(DIPR):DIPR,$G(DPP(0))]"":"BY(0)",1:$P(DPP(DJ-1),U,3)),DV=$J("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY" D L^DIP0 K DIPR G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"
  1.  I DJ>1!($G(DPP(0))=0) D  G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"  G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
  1.  . S DIPR=$S($D(DIPR):DIPR,$G(DPP(0))]"":"BY(0)",1:$P(DPP(DJ-1),U,3))
  1.  . S DV=$J("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY"
  1.  . D L^DIP0 K DIPR Q
  1.  ;I DJ>1 G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
  1.  S P=$P(^DD(DL,.01,0),U,1,2)  D:'$D(DIPP) XR:$P(P,U,2)'["P"&($P(P,U,2)'["V") I 'DU S Y=S,DV(1)=$S($D(^DD(DL,.001,0)):$P(^(0),U),1:"NUMBER")
  1. D1 S DPP(DJ)=$S($D(DIPP(DIJ)):DIPP(DIJ),1:Y_U_DU_U_DV(1)_U)
  1.  S DV=DE_" BY" D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) I X="" D DJ^DIP1 Q
  1.  G:$D(DIPP) ADD:X?1"^"1.E Q:X="@"
  1. D K DPP(DJ,"IX"),DPP(DJ,"PTRIX") S R=U,P=DNP I X="]" S DXS=1,DJ=DJ-1 Q
  1. Y I X'="NUMBER" D ^DIC K DUOUT G Q:$D(DTOUT)!(X=U) G G:Y>0,TEM^DIP11:X?1"[".E&'$D(DIPP)&($G(DIEDT)'=1),B:X=""
  1.  I $G(DUZ(0))="@",X="BY(0)",DJ=1,'$D(DIPP),DL=S D  G:$G(DTOUT)!($G(DIROUT)) Q  G:Y=1 DJ S X="",DPP=DPP(0) Q
  1.  . N X D ENBY0^DIP100 I $G(BY(0))="" S Y=1 Q
  1.  . S DIR(0)="Y",DIR("A")="Enter additional sort fields",DIR("B")="NO",DIR("?")="Enter YES if you wish to sort by fields in addition to BY(0)." D ^DIR K DIR
  1.  . W ! Q
  1. STRIP D  G:'$D(D) Y S X=$RE(X) D  S X=$RE(X) G:'$D(D) Y ;from beginning, then end
  1.  .F D="]","-","#","+","!","@","'" I $E(X)=D S P=P_D,X=$E(X,2,999) S:D="]" DXS=1 K D Q
  1.  I X[";" S R=X,X=$P(X,";"),R=U_$P(R,X,2,9) G Y
  1.  S D="NUMBER",Y=0_U_D I $P(D,X)="" W $P(D,X,2) G S
  1.  G ^DIP0
  1.  ;
  1. BB S DPP(DJ,"F")=0,DPP(DJ,"T")=1,P=P_$S(P["@":"B",1:"@B"),R=R_$S(R'[";L1":";L1",1:"") K DATE Q
  1. G S X=$P(Y(0),U,2),D=$P($P(Y(0),U,4),";") G NM:'X
  1.  S N=N+1,DPP(DJ,DL)=D,DIL(+X)=DL,I(N)=$S(+D=D:D,1:Q_D_Q),(DL,J(N))=+X,Y=.01_U_$P(^DD(DL,.01,0),U) I $D(DIPP(DIJ))#2 S %=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$S($D(DIPP(DIJ,DL)):DIPP(DIJ,DL),1:%)
  1.  I $O(^DD(DL,0))>0!$S($D(BY):BY?1U.E1" ".E,1:0) S DV=$J("",DJ*2-2)_$P(^(0),U) D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"  G Y
  1. NM D BB:X["B" I X["P"!(X["V") S P=P_Q_+Y,I=$P(Y,U,2),DPP(DJ)=DL_U_Y_U_P D DPQ^DIP1 S X="#"_$P(P,Q,$L(P,Q)),DPP=I G C^DIP0
  1.  I +Y=.001 S Y=0_U_$P(Y,U,2),R=R_U_U_X
  1. S ;
  1.  S X=DL_U_+Y,DPP(DJ)=DL_U_Y_U_P_R I P'["-",R'[";TXT",$P(Y,U,3)="" D XR
  1.  D DJ^DIP1 S:X'=U X=1 Q
  1. B W $C(7),"??" Q:$D(DIJS)  G DJ
  1.  ;
  1. XR I $P($G(DPP(DJ)),U,3)="NUMBER",+DPP(DJ)=S,$P(DPP(DJ),U,2)=0 S DPP(DJ,"IX")=DI_DI_U_1 Q
  1.  I 'Y S Y=+$P($P(DPP(DJ),U,4),"""",2) Q:'Y  D
  1.  . N P,X,Z S Z=+$P($P(^DD(+DPP(DJ),Y,0),U,2),"P",2) G:'Z XER
  1.  . D DTYP^DIOU(Z,.01,.P) G:P>4 XER S P=$P($G(^DD(Z,.01,0)),U,2) I P["O",P'[D G XER
  1.  . F P=0:0 S P=$O(^DD(Z,.01,1,P)) Q:'P  I +^(P,0)=Z,$P(^(0),U,2,9)="B" Q
  1.  . I 'P S P=$O(^DD("IX","BB",Z,"B",0)) I P S P=$$IDXOK(P,Z,Z,.01)
  1.  . G:'P XER S P=$G(^DIC(Z,0,"GL")) G:P="" XER
  1.  . S DPP(DJ,"PTRIX")=P_Q_"B"_Q_C Q
  1. XER . S Y="" Q
  1.  S P=$P($G(^DD(DL,+Y,0)),U,2) D
  1.  . I P["O",P'["D" Q
  1.  . I P?.E1"NJ"1.N1",2".E,$P($G(^DD(DL,+Y,0)),U,5,99)["""$""" Q
  1.  . F P=0:0 S P=$O(^DD(DL,+Y,1,P)) Q:P'>0  I +^(P,0)=S S X=$P(^(0),U,2,9) I X?1A.AN S DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2,Y=+$O(^DD(S,0,"IX",X,-1)),DU=+$O(^(Y,-1)),DV(1)=$P(^DD(Y,DU,0),U) Q
  1.  . Q:P
  1.  . N DIOUT S DIOUT=0
  1.  . F  S P=$O(^DD("IX","F",DL,+Y,P)) Q:'P  S X=$P($G(^DD("IX",P,0)),U,2) I X]"" D  Q:DIOUT
  1.  . . Q:'$$IDXOK(P,S,DL,+Y)
  1.  . . S DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2
  1.  . . S DU=+Y,Y=DL,DV(1)=$P(^DD(DL,DU,0),U),DIOUT=1 Q
  1.  . Q
  1.  I $D(DPP(DJ,"PTRIX")),'$D(DPP(DJ,"IX")) K DPP(DJ,"PTRIX")
  1.  Q
  1.  ;
  1. IDXOK(DIEN,DIFILE,DISUB,DIFIELD) ;
  1.  N X S X=$G(^DD("IX",DIEN,0))
  1.  Q:$P(X,U,14)'["S" 0
  1.  Q:+X'=DIFILE 0
  1.  N J S J=$O(^DD("IX",DIEN,11.1,0)) Q:'J 0
  1.  I $O(^DD("IX",DIEN,11.1,J)) Q 0
  1.  S X=$G(^DD("IX",DIEN,11.1,J,0))
  1.  I ('$P(X,U,6))!($P(X,U,3)'=DISUB)!($P(X,U,4)'=DIFIELD) Q 0
  1.  I $D(^DD("IX",DIEN,11.1,J,1.5))!($D(^(2))) Q 0
  1.  Q 1
  1.  ;
  1. ADD S X=$E(X,2,99),DIJS=DIJ,DIJ=0 D D I $G(X)=U!($D(DTOUT)) K DIJS Q
  1.  S:$D(X) DJ=DJ+1 S DIJ=DIJS K DIJS G DJ