Return to DDS41.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDS41	;SFISC/MKO-VERIFY DATA ;07:42 AM  25 Oct 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	N DDO
    5: 	K DDSERROR,DDS4DONE,DDS4ERR
    6: 	S DDS4PG=DDSPG
    7: 	;
    8: 	;Set DA,DIE,DDP array to its original value
    9: 	I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D
   10: 	. S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_","
   11: 	. F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_","
   12: 	. S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE=""
   13: 	;
   14: 	D LDALL
   15: 	I $G(DIERR) D  G END
   16: 	. N P
   17: 	. S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U)
   18: 	. S:P(2)="" P(2)="unnamed"
   19: 	. D BLD^DIALOG(3041,.P),ERR^DDSMSG
   20: 	. S DDS4ERR=1
   21: 	;
   22: 	D LP
   23: 	;
   24: 	S DDSPG=DDS4PG,DDS4VC=$G(^DIST(.403,+DDS,20))
   25: 	I DDS4VC'?."^"  K @DDSREFT@("MSG") X DDS4VC
   26: 	I $G(@DDSREFT@("MSG"))>0!$G(DIERR) D PRNT
   27: 	;
   28: END	S Y='$D(DDSERROR)&'$G(DDS4ERR)
   29: 	K DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4PG,DDS4TP
   30: 	K DDS4VC,DDSCAP,DDSDD,DDSERROR,DDSI,DDSPID
   31: 	K DDSREQ,DIERR,DV
   32: 	Q
   33: 	;
   34: LDALL	;Load all pages
   35: 	S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),""))
   36: 	S Y=1
   37: 	F  D ^DDS1(DDSPG) Q:$G(DIERR)  S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y
   38: 	K DDS4PG1
   39: 	Q
   40: 	;
   41: LP	;Loop through all pages/blocks
   42: 	S DX=0,DY=IOSL-1 X IOXY
   43: 	W "Verifying ..."_$P(DDGLCLR,DDGLDEL)
   44: 	;
   45: 	S DDSPG=0
   46: 	F  S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG  D
   47: 	. S DDS4B=0
   48: 	. F  S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B  D
   49: 	.. I '$D(DDS4DONE(DDS4B)),$P(@DDSREFS@(DDSPG,DDS4B),U,5)="e" D
   50: 	... S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))
   51: 	... D VB
   52: 	Q
   53: 	;
   54: VB	;Loop through all fields on block
   55: 	N DDP
   56: 	S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2)
   57: 	S DDO=0 F  S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO  D VF
   58: 	Q
   59: 	;
   60: VF	;Check for required fields
   61: 	Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0  S DDS4TP=$P(^(0),U,3)
   62: 	Q:DDS4TP=1  Q:DDS4TP=4
   63: 	S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
   64: 	;
   65: 	I DDS4TP=2 N DDP D
   66: 	. S DDP=0,DDS4FLD=DDO_","_DDS4B
   67: 	. K DV
   68: 	;
   69: 	E  D  Q:DDS4FLD'=+$P(DDS4FLD,"E")!(DDS4FLD=.01)
   70: 	. S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1))
   71: 	. S DDSDD=$G(^DD(DDP,DDS4FLD,0)),DV=$P(DDSDD,U,2)
   72: 	. S:DDSCAP="" DDSCAP=$S($G(^DD(DDP,DDS4FLD,.1))]"":^(.1),1:$P(DDSDD,U))
   73: 	;
   74: 	S DDS4DA=" "
   75: 	F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA=""  D
   76: 	. I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q
   77: 	. N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA
   78: 	. S DDS4DA=""
   79: 	. F  S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA  D VR
   80: 	Q
   81: 	;
   82: VR	;Check that value is non-null for record
   83: 	S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U)
   84: 	S:$P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" DDSREQ=$P(^("A"),U)
   85: 	;
   86: 	I DDSREQ'=1,$G(DV)'["R" Q
   87: 	;
   88: 	;Required WP fields (quit if mult)
   89: 	I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M")  Q
   90: 	. I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D"))
   91: 	. E  S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")"
   92: 	. S (DDS4VAL,DDS4I)=0
   93: 	. F  S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I  I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q
   94: 	. D:'DDS4VAL LDERR
   95: 	. K DDS4REF,DDS4I,DDS4VAL
   96: 	;
   97: 	I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR
   98: 	Q
   99: 	;
  100: LDERR	;Call ^DIALOG to load error
  101: 	N P
  102: 	I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091)
  103: 	S P(1)=DDSPID,P(2)=DDSCAP,P(3)=""
  104: 	I $L(DDS4DA,",")>2 D
  105: 	. N Y,C
  106: 	. S P(3)=$P(@(@DDSREFT@(DDSPG,DDS4B,$G(DDS4PDA,DDS4DA),"GL")_+DDS4DA_",0)"),U)
  107: 	. Q:P(3)=""
  108: 	. S Y=P(3),C=$P(^DD(DDP,.01,0),U,2) D Y^DIQ S P(3)=Y
  109: 	. S P(3)="(Subrecord: "_P(3)_")"
  110: 	D BLD^DIALOG(3092,.P)
  111: 	Q
  112: 	;
  113: PRNT	;
  114: 	S (DDSABT,DX,DY)=0,$X=0,$Y=0 X IOXY
  115: 	W $P(DDGLCLR,DDGLDEL,2)
  116: 	;
  117: 	I $G(DIERR) D
  118: 	. S DDSI=0
  119: 	. F  S DDSI=$O(^TMP("DIERR",$J,DDSI)) Q:'DDSI!DDSABT  D
  120: 	.. S DDSJ=0
  121: 	.. F  S DDSJ=$O(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ)) Q:'DDSJ!DDSABT  D
  122: 	... D:$G(^TMP("DIERR",$J,DDSI,"TEXT",DDSJ))]"" WLIN(^(DDSJ))
  123: 	G:DDSABT PRNTEND
  124: 	;
  125: 	I $D(@DDSREFT@("MSG")) D
  126: 	. S DDSI=0
  127: 	. F  S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI!DDSABT  D
  128: 	.. D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI))
  129: 	;
  130: 	D EOP
  131: 	;
  132: PRNTEND	W $P(DDGLCLR,DDGLDEL,2)
  133: 	K DDSABT,DDSI,DDSJ
  134: 	K @DDSREFT@("MSG"),^TMP("DIERR",$J)
  135: 	Q
  136: 	;
  137: WLIN(DDSX)	;
  138: 	;Write a single line, wrap at word boundaries
  139: 	S DDSWIDTH=IOM-1
  140: 	F  Q:DDSX=""!DDSABT  D
  141: 	. F DDSSP=$L(DDSX," "):-1:1 I $L($P(DDSX," ",1,DDSSP))<DDSWIDTH D  Q
  142: 	.. I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q
  143: 	.. W !,$P(DDSX," ",1,DDSSP)
  144: 	.. S DDSX=$P(DDSX," ",DDSSP+1,999)
  145: 	K DDSWIDTH
  146: 	Q
  147: EOP	;
  148: 	N X
  149: 	S DX=0,DY=IOSL-1 X IOXY
  150: 	R "Press RETURN to continue: ",X:DTIME
  151: 	S Y=X'[U&$T
  152: 	Q