Annotation of freem_fileman/DDS41.m, revision 1.1
1.1 ! snw 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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDS41.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman