Return to DIBT.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Initial revision

DIBT	;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;8/24/94  13:04
	;;21.0;VA FileMan;;Dec 28, 1994
	;Per VHA Directive 10-93-142, this routine should not be modified.
0	;
	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"
	S DIK=DIC D IXALL^DIK
1	;
	S DICF=DI,DIC(0)="QEAIN" D ^DIC K DIC Q:Y<0  S DIC=+Y
11	W !! Q:$D(DTOUT)  S DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF
	S DIC(0)="AEQI" D IX^DIC I Y<0 K DIC,DICF Q
	S DA=+Y,DIE=DIC,DR=".01:3;5:7;10;707;491620",DIOVRD=1 D ^DIE K DR,DIOVRD G 11
	;
S	;
	D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT))
	G N:X="",S:Y<0
	S DIBT1=+Y
SNEW	K ^DIBT(DIBT1,2) S $P(^DIBT(DIBT1,0),U,7)=DT
	S (DIBT2,DIBT3)=0 F  S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3  S DIBT2=DIBT2+1 D
	.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
	.N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10)
	.S A="A" F  S A=$O(DPP(DIBT3,A)) Q:A=""  S %=$G(DPP(DIBT3,A)) S:%]"" ^DIBT(DIBT1,2,DIBT2,A)=%
	.S (C,D)=0 F A=0:0 S A=$O(DPP(DIBT3,A)) Q:'A  D
	..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM
	..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)
	..Q
	.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
	.Q
	I $D(DIBTOLD) K DIBTOLD D K Q
	S DIBT2=0
S0	S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B"
	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."
	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
	G:Y=0 S0
S1	S ^DIBT(DIBT1,2,DIBT2,"ASK")=1
	G S0
	;
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)
	N C,D
	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
	N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q
	;
US	S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q
	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
	.F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT" S:$D(DPP(X,%)) ^DIBT(DIBT1,2,A,%)=DPP(X,%)
	.Q
	Q
	;
K	K DIEDT,DIBT2,DIBT3 Q
N	D K G N^DIP1