Return to DDS41.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

DDS41	;SFISC/MKO-VERIFY DATA ;07:42 AM  25 Oct 1994
	;;21.0;VA FileMan;;Dec 28, 1994
	;Per VHA Directive 10-93-142, this routine should not be modified.
	N DDO
	K DDSERROR,DDS4DONE,DDS4ERR
	S DDS4PG=DDSPG
	;
	;Set DA,DIE,DDP array to its original value
	I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
	. S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
	. F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
	. S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
	;
	D LDALL
	I $G(DIERR) D  G END
	. N P
	. S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
	. S:P(2)="" P(2)="unnamed"
	. D BLD^DIALOG(3041,.P),ERR^DDSMSG
	. S DDS4ERR=1
	;
	D LP
	;
	S DDSPG=DDS4PG,DDS4VC=$G(^DIST(.403,+DDS,20))
	I DDS4VC'?."^"  K @DDSREFT@("MSG") X DDS4VC
	I $G(@DDSREFT@("MSG"))>0!$G(DIERR) D PRNT
	;
END	S Y='$D(DDSERROR)&'$G(DDS4ERR)
	K DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4PG,DDS4TP
	K DDS4VC,DDSCAP,DDSDD,DDSERROR,DDSI,DDSPID
	K DDSREQ,DIERR,DV
	Q
	;
LDALL	;Load all pages
	S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),""))
	S Y=1
	F  D ^DDS1(DDSPG) Q:$G(DIERR)  S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y
	K DDS4PG1
	Q
	;
LP	;Loop through all pages/blocks
	S DX=0,DY=IOSL-1 X IOXY
	W "Verifying ..."_$P(DDGLCLR,DDGLDEL)
	;
	S DDSPG=0
	F  S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG  D
	. S DDS4B=0
	. F  S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B  D
	.. I '$D(DDS4DONE(DDS4B)),$P(@DDSREFS@(DDSPG,DDS4B),U,5)="e" D
	... S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))
	... D VB
	Q
	;
VB	;Loop through all fields on block
	N DDP
	S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2)
	S DDO=0 F  S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO  D VF
	Q
	;
VF	;Check for required fields
	Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0  S DDS4TP=$P(^(0),U,3)
	Q:DDS4TP=1  Q:DDS4TP=4
	S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
	;
	I DDS4TP=2 N DDP D
	. S DDP=0,DDS4FLD=DDO_","_DDS4B
	. K DV
	;
	E  D  Q:DDS4FLD'=+$P(DDS4FLD,"E")!(DDS4FLD=.01)
	. S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1))
	. S DDSDD=$G(^DD(DDP,DDS4FLD,0)),DV=$P(DDSDD,U,2)
	. S:DDSCAP="" DDSCAP=$S($G(^DD(DDP,DDS4FLD,.1))]"":^(.1),1:$P(DDSDD,U))
	;
	S DDS4DA=" "
	F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA=""  D
	. I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q
	. N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA
	. S DDS4DA=""
	. F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA  D VR
	Q
	;
VR	;Check that value is non-null for record
	S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U)
	S:$P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" DDSREQ=$P(^("A"),U)
	;
	I DDSREQ'=1,$G(DV)'["R" Q
	;
	;Required WP fields (quit if mult)
	I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M")  Q
	. I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D"))
	. E  S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")"
	. S (DDS4VAL,DDS4I)=0
	. F  S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I  I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q
	. D:'DDS4VAL LDERR
	. K DDS4REF,DDS4I,DDS4VAL
	;
	I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR
	Q
	;
LDERR	;Call ^DIALOG to load error
	N P
	I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091)
	S P(1)=DDSPID,P(2)=DDSCAP,P(3)=""
	I $L(DDS4DA,",")>2 D
	. N Y,C
	. S P(3)=$P(@(@DDSREFT@(DDSPG,DDS4B,$G(DDS4PDA,DDS4DA),"GL")_+DDS4DA_",0)"),U)
	. Q:P(3)=""
	. S Y=P(3),C=$P(^DD(DDP,.01,0),U,2) D Y^DIQ S P(3)=Y
	. S P(3)="(Subrecord: "_P(3)_")"
	D BLD^DIALOG(3092,.P)
	Q
	;
PRNT	;
	S (DDSABT,DX,DY)=0,$X=0,$Y=0 X IOXY
	W $P(DDGLCLR,DDGLDEL,2)
	;
	I $G(DIERR) D
	. S DDSI=0
	. F  S DDSI=$O(^TMP("DIERR",$J,DDSI)) Q:'DDSI!DDSABT  D
	.. S DDSJ=0
	.. F  S DDSJ=$O(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ)) Q:'DDSJ!DDSABT  D
	... D:$G(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ))]"" WLIN(^(DDSJ))
	G:DDSABT PRNTEND
	;
	I $D(@DDSREFT@("MSG")) D
	. S DDSI=0
	. F  S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI!DDSABT  D
	.. D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI))
	;
	D EOP
	;
PRNTEND	W $P(DDGLCLR,DDGLDEL,2)
	K DDSABT,DDSI,DDSJ
	K @DDSREFT@("MSG"),^TMP("DIERR",$J)
	Q
	;
WLIN(DDSX)	;
	;Write a single line, wrap at word boundaries
	S DDSWIDTH=IOM-1
	F  Q:DDSX=""!DDSABT  D
	. F DDSSP=$L(DDSX," "):-1:1 I $L($P(DDSX," ",1,DDSSP))<DDSWIDTH D  Q
	.. I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q
	.. W !,$P(DDSX," ",1,DDSSP)
	.. S DDSX=$P(DDSX," ",DDSSP+1,999)
	K DDSWIDTH
	Q
EOP	;
	N X
	S DX=0,DY=IOSL-1 X IOXY
	R "Press RETURN to continue: ",X:DTIME
	S Y=X'[U&$T
	Q