Return to DIBT.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIBT	;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;8/24/94  13:04
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 0	;
    5: 	S DIC="^DOPT(""DIBT""," G 1:$D(^DOPT("DIBT",.402)) S ^(0)="TEMPLATE FILE^1.01" K ^("B") F X=.4,.401,.402 S ^DOPT("DIBT",X,0)=$P("PRINT^SORT^INPUT",U,$E(X,4)+1)_" TEMPLATE"
    6: 	S DIK=DIC D IXALL^DIK
    7: 1	;
    8: 	S DICF=DI,DIC(0)="QEAIN" D ^DIC K DIC Q:Y<0  S DIC=+Y
    9: 11	W !! Q:$D(DTOUT)  S DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF
   10: 	S DIC(0)="AEQI" D IX^DIC I Y<0 K DIC,DICF Q
   11: 	S DA=+Y,DIE=DIC,DR=".01:3;5:7;10;707;491620",DIOVRD=1 D ^DIE K DR,DIOVRD G 11
   12: 	;
   13: S	;
   14: 	D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT))
   15: 	G N:X="",S:Y<0
   16: 	S DIBT1=+Y
   17: SNEW	K ^DIBT(DIBT1,2) S $P(^DIBT(DIBT1,0),U,7)=DT
   18: 	S (DIBT2,DIBT3)=0 F  S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3  S DIBT2=DIBT2+1 D
   19: 	.N DIC,DA,DIE,DINUM,DIOVRD,DR S X=+DPP(DIBT3) Q:'X  S DIC="^DIBT("_DIBT1_",2,",DIC(0)="L",DA(1)=DIBT1,DINUM=DIBT2,DIOVRD=1,DIC("P")=$P(^DD(.401,1621,0),U,2) D FILE^DICN K DIC,DA,DINUM,DIOVRD
   20: 	.N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10)
   21: 	.S A="A" F  S A=$O(DPP(DIBT3,A)) Q:A=""  S %=$G(DPP(DIBT3,A)) S:%]"" ^DIBT(DIBT1,2,DIBT2,A)=%
   22: 	.S (C,D)=0 F A=0:0 S A=$O(DPP(DIBT3,A)) Q:'A  D
   23: 	..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM
   24: 	..S B="" F  S B=$O(DPP(DIBT3,A,B)) Q:B=""  S D=D+1,%=2,%(1)=18,X=A,DINUM=D D DICM S:Y>0 ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$P(DPP(DIBT3,A,B),U,4,99)
   25: 	..Q
   26: 	.S D=0,A="OV" F  S A=$O(DPP(DIBT3,A)) Q:$E(A,1,2)'="OV"  S B="" F  S B=$O(DPP(DIBT3,A,B)) Q:B=""  S C=$G(DPP(DIBT3,A,B)) I C]"" S D=D+1,%=3,%(1)=19,X=A,DINUM=D D DICM I Y>0 S $P(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B,^("OVF0")=C
   27: 	.Q
   28: 	I $D(DIBTOLD) K DIBTOLD D K Q
   29: 	S DIBT2=0
   30: S0	S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B"
   31: 	S DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and",DIR("?")="ending sort values when the print job is run."
   32: 	W ! S DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$P(DPP(DIBT2),U,3)_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) D K G Q^DIP
   33: 	G:Y=0 S0
   34: S1	S ^DIBT(DIBT1,2,DIBT2,"ASK")=1
   35: 	G S0
   36: 	;
   37: DICM	S DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_",",DA(2)=DIBT1,DA(1)=DIBT2,DIC(0)="L",DIOVRD=1,DIC("P")=$P(^DD(.4014,%(1),0),U,2)
   38: 	N C,D
   39: 	I %(1)=18 S DIC("DR")="1////"_B F C=1,2,3 S D=$P(DPP(DIBT3,A,B),U,C) I D]"" S DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D
   40: 	N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q
   41: 	;
   42: US	S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q
   43: 	N %,A S X=+$G(DPP(0)),A=0 F X=X:0 S X=$O(DPP(X)) Q:'X  S A=A+1 D
   44: 	.F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT" S:$D(DPP(X,%)) ^DIBT(DIBT1,2,A,%)=DPP(X,%)
   45: 	.Q
   46: 	Q
   47: 	;
   48: K	K DIEDT,DIBT2,DIBT3 Q
   49: N	D K G N^DIP1