- DIVR1 ;SFISC/DCM-VERIFY FIELDS API ;9:16 AM 1 Jul 1999
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- EN ;
- I '$D(DIVRREC) S DIVRREC=""
- N %ZIS,POP,ZTRTN,ZTSAVE,SUB
- S %ZIS="Q" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTRTN="DQ^DIVR1",(ZTSAVE("DIVRFILE"),ZTSAVE("DIVRDR"),ZTSAVE("DIVROUT"))="" S SUB="DIVRREC"_$S($D(DIVRREC)=10:"(",1:"") S ZTSAVE(SUB)="" D ^%ZTLOAD Q
- DQ N PG,TAB,REC,Y,DATE,I,J,K,DIVRFI0,DIVRFINM,DIVRFIIN,DA,V,DIRUT,R,DE,DIUTIL
- K ^TMP("DIVR1",$J),^TMP("DIERR",$J)
- I $D(ZTQUEUED) S ZTREQ="@"
- S PG=0,TAB=0,REC=0,DIUTIL="VERIFY FIELDS" U IO
- S Y=DT D DD^%DT S DATE=Y
- D DIVRFILE Q:$G(DIERR)
- D DIVRREC
- I '$D(^TMP("DIVR1",$J)),'$G(DIERR) W !!!,?20,"*** NO ERRORS FOUND ***" D Q
- D DIVROUT^DIV,Q
- Q
- DIVRFILE S (DIVRFILE,DIVRFIIN)=+DIVRFILE
- Q:'$$VFILE^DILFD(DIVRFILE,"D")
- S DIVRFI0=$$FNO^DILIBF(DIVRFILE),DIVRFINM=$$GET1^DID(DIVRFI0,"","","NAME")
- Q
- DIVRREC S R=$D(DIVRREC)
- I $D(DIVRREC)#2,(DIVRREC=""!(DIVRREC="ALL")) S R=0 D IJ^DIVU(DIVRFIIN),H1,DIVRDR Q
- I $D(DIVRREC)#2,$E(DIVRREC)="[" D Q
- . N Y,D0,DS D DIBT^DIVU(DIVRREC,.Y,DIVRFI0) Q:Y'>0
- . S D0=0 D H2,IJ^DIVU(DIVRFI0) F S D0=$O(^DIBT(+Y,1,D0)) Q:D0'>0 S DE="",DS=1 D:$$VENTRY^DIEFU(DIVRFI0,+D0,"D") DIVRDR Q:$D(DIRUT)
- I $D(DIVRREC)=10 D Q
- . N I S I="" D H2,IJ^DIVU(DIVRFIIN)
- . F S I=$O(DIVRREC(I)) Q:I'>0 S DIVRREC=I D ONE
- D H2,IJ^DIVU(DIVRFIIN)
- ONE Q:'$$IENCHK^DIT3(DIVRFIIN,DIVRREC)
- Q:'$$VENTRY^DIEFU(DIVRFIIN,DIVRREC,"D")
- N %,DEPTH,D,DS
- S DEPTH=$L(DIVRREC,",")-1
- F %=1:1:DEPTH S D="D"_(DEPTH-%) N @D S @D=$P(DIVRREC,",",%)
- S DS=DEPTH D DIVRDR
- Q
- DIVRDR N FLD,PC,Z,END,OUT,F,Y,Q,S
- S F=1,FLD=0,Q="""",S=";"
- S:$G(DIVRDR)="" DIVRDR="ALL"
- I DIVRDR="ALL" D Q
- . F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0 D SET Q:$D(DIRUT)
- F S Z=$G(Z)+1 S PC=$P(DIVRDR,S,Z) Q:PC="" D Q:$D(DIRUT)
- . N Z
- . I PC[":" S FLD=$O(^DD(DIVRFILE,+PC),-1),END=+$P(PC,":",2) D Q
- . . F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0!(FLD>END) D SET Q:$D(DIRUT)
- . S FLD=PC I $$VFIELD^DILFD(DIVRFILE,PC,"D") D SET Q
- Q
- SET N TYP,IT,T,W,PC3,M,Y,KEY
- S Y=FLD,Y(0)=^DD(DIVRFILE,FLD,0),TYP=$P(Y(0),U,2),IT=$P(Y(0),U,5,99),PC3=$P(Y(0),U,3)
- F T="N","D","P","S","V","F" Q:TYP[T
- F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K" I T[$E(W) S:W="K" W="MUMPS" Q
- I TYP["C" Q
- I TYP,$P(^DD(+TYP,.01,0),U,2)["W" Q
- I TYP D MULT Q
- I 'R D:$Y>(IOSL-4) FF Q:$D(DIRUT) W !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_" (#"_FLD_")",?40,W
- I TYP["*",TYP'["X" S IT="Q" I $D(^DD(DIVRFILE,FLD,12.1)) X ^(12.1) I $D(DIC("S")) S IT(1)=DIC("S"),IT="X IT(1) E K X"
- S KEY=$D(^DD("KEY","F",DIVRFILE,FLD))>9
- D XDE
- Q
- XDE I F D
- .I R,DIVRFILE=DIVRFIIN S DE="D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
- .D DE^DIVU(DIVRFILE,"","","DE",$G(DS)_U_$G(DS)) S F=0,DE=DE_" D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)" Q
- D DE99(DIVRFILE,FLD)
- X DE
- Q
- MULT D:$Y>(IOSL-4) FF Q:$D(DIRUT)
- W:'R !!?TAB,$P(^DD(DIVRFILE,FLD,0),U)_"(#"_FLD_") --multiple--"
- N DIVRFILE,FLD,DA,V,I,J,K,F,DE
- S DIVRFILE=+TYP,FLD=0,TAB=TAB+2,F=1 D IJ^DIVU(DIVRFILE)
- F S FLD=$O(^DD(DIVRFILE,FLD)) Q:FLD'>0 D SET Q:$D(DIRUT)
- S TAB=TAB-2 K @("D"_V)
- Q
- R I X?." " Q:TYP'["R"&'KEY D Q
- . I X="" S M="Missing"_$S(KEY:" key value",1:"")
- . E S M="Equals only 1 or more spaces"
- . D X
- D @T Q
- P I @("$D(^"_PC3_"X,0))") D F Q
- S M="No '"_X_"' in pointed-to File" D X Q
- V I $P(X,S,2)'?1A.AN1"(".ANP,$P(X,S,2)'?1"%".AN1"(".ANP S M=Q_X_Q_" has the wrong format" D X Q
- S M=$S($D(@(U_$P(X,S,2)_"0)")):^(0),1:"")
- I '$D(^DD(DIVRFILE,FLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" D X Q
- I '$D(@(U_$P(X,S,2)_+X_",0)")) S M=U_$P(X,S,2)_+X_",0) does not exist" D X Q
- D F Q
- S S Y=X I TYP'["X" X IT I '$D(X) S M=Q_Y_Q_" fails screen" D X Q
- Q:S_PC3[(S_X_":") S M=Q_X_Q_" not in Set" D X Q
- D N Y,%DT S Y=$F(IT,"%DT=""E") S:Y IT=$E(IT,1,Y-2)_$E(IT,Y,999)
- I TYP["X" X $P(IT," D ^%DT") D ^%DT I Y<0 S M="Invalid date" D X Q
- D F Q
- N I TYP["X",X'?.1"-".N.".".N S M="Invalid number" D X Q
- D F Q
- K D ^DIM I '$D(X) S M="Invalid M code" D X
- Q
- F N Y S Y=X I X'?.ANP S M="Non-printing character" D X
- IT Q:TYP["X" D Q:$D(X) S M=Q_Y_Q_" fails Input Transform"
- .N %Y S %Y=Y X IT S Y=%Y
- ;
- X S X=$S(V:DA(V),1:DA),^TMP("DIVR1",$J,$S('R:X,$G(DIVRREC)["[":X,(R&($G(DIVROUT)["[")):X,1:DIVRREC))="",X=V,Z=0
- I @(I(0)_"0)")
- IEN D FF:$Y>(IOSL-3) Q:$D(DIRUT)
- I 'R D Q
- .F Q:'X W !?5,@("D"_Z),?15,$P(^(@("D"_Z),0),U) S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
- .W !?5,@("D"_Z),?15,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)),?50,$E(M,1,40) W:V !
- I R D Q
- .F Q:'X W !,@("D"_Z),?10,$P(^(@("D"_Z),0),U) W:Z " (",K(Z),")" S X=X-1,Z=Z+1,@("Y=$D(^("_I(V-X)_",0))")
- .W !,@("D"_Z),?10,$S($D(^(@("D"_Z),0)):$P(^(0),U),1:@("D"_Z)) W:Z " (",K(Z),")" W !?5,$P(^DD(DIVRFILE,FLD,0),U)," (#",FLD,")",?35,W,?50,M W:V !
- Q
- ;
- DE99(FI,FD,NP) ;
- N Y
- D GET^DIOU(FI,FD,"X",.Y,"I")
- S DE(99)=Y_" D R " Q
- Q
- Q D ^%ZISC
- Q
- FF I IOST["C-" N DIR,X,Y S DIR(0)="E" D ^DIR Q:$D(DIRUT)
- I R D H2 Q
- H1 W:$Y @IOF W "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
- W !,"Field Name (Field #)",?40,"Type"
- W !?5,"Entry #",?15,"Name",?50,"ERROR"
- N L W ! F L=1:1:(IOM-2) W "-"
- S PG=PG+1
- Q
- H2 W:$Y @IOF W "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25) W DATE W ?(IOM-9),"PAGE ",PG+1
- W !,"Entry #",?10,"Name"
- W !?5,"Field Name (Field #)",?35,"Type",?50,"ERROR"
- N L W ! F L=1:1:(IOM-2) W "-"
- S PG=PG+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIVR1 5713 printed Mar 13, 2025@21:59:38 Page 2
- DIVR1 ;SFISC/DCM-VERIFY FIELDS API ;9:16 AM 1 Jul 1999
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- EN ;
- +1 IF '$DATA(DIVRREC)
- SET DIVRREC=""
- +2 NEW %ZIS,POP,ZTRTN,ZTSAVE,SUB
- +3 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +4 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^DIVR1"
- SET (ZTSAVE("DIVRFILE"),ZTSAVE("DIVRDR"),ZTSAVE("DIVROUT"))=""
- SET SUB="DIVRREC"_$SELECT($DATA(DIVRREC)=10:"(",1:"")
- SET ZTSAVE(SUB)=""
- DO ^%ZTLOAD
- QUIT
- DQ NEW PG,TAB,REC,Y,DATE,I,J,K,DIVRFI0,DIVRFINM,DIVRFIIN,DA,V,DIRUT,R,DE,DIUTIL
- +1 KILL ^TMP("DIVR1",$JOB),^TMP("DIERR",$JOB)
- +2 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 SET PG=0
- SET TAB=0
- SET REC=0
- SET DIUTIL="VERIFY FIELDS"
- USE IO
- +4 SET Y=DT
- DO DD^%DT
- SET DATE=Y
- +5 DO DIVRFILE
- if $GET(DIERR)
- QUIT
- +6 DO DIVRREC
- +7 IF '$DATA(^TMP("DIVR1",$JOB))
- IF '$GET(DIERR)
- WRITE !!!,?20,"*** NO ERRORS FOUND ***"
- DO Q
- +8 DO DIVROUT^DIV
- DO Q
- +9 QUIT
- DIVRFILE SET (DIVRFILE,DIVRFIIN)=+DIVRFILE
- +1 if '$$VFILE^DILFD(DIVRFILE,"D")
- QUIT
- +2 SET DIVRFI0=$$FNO^DILIBF(DIVRFILE)
- SET DIVRFINM=$$GET1^DID(DIVRFI0,"","","NAME")
- +3 QUIT
- DIVRREC SET R=$DATA(DIVRREC)
- +1 IF $DATA(DIVRREC)#2
- IF (DIVRREC=""!(DIVRREC="ALL"))
- SET R=0
- DO IJ^DIVU(DIVRFIIN)
- DO H1
- DO DIVRDR
- QUIT
- +2 IF $DATA(DIVRREC)#2
- IF $EXTRACT(DIVRREC)="["
- Begin DoDot:1
- +3 NEW Y,D0,DS
- DO DIBT^DIVU(DIVRREC,.Y,DIVRFI0)
- if Y'>0
- QUIT
- +4 SET D0=0
- DO H2
- DO IJ^DIVU(DIVRFI0)
- FOR
- SET D0=$ORDER(^DIBT(+Y,1,D0))
- if D0'>0
- QUIT
- SET DE=""
- SET DS=1
- if $$VENTRY^DIEFU(DIVRFI0,+D0,"D")
- DO DIVRDR
- if $DATA(DIRUT)
- QUIT
- End DoDot:1
- QUIT
- +5 IF $DATA(DIVRREC)=10
- Begin DoDot:1
- +6 NEW I
- SET I=""
- DO H2
- DO IJ^DIVU(DIVRFIIN)
- +7 FOR
- SET I=$ORDER(DIVRREC(I))
- if I'>0
- QUIT
- SET DIVRREC=I
- DO ONE
- End DoDot:1
- QUIT
- +8 DO H2
- DO IJ^DIVU(DIVRFIIN)
- ONE if '$$IENCHK^DIT3(DIVRFIIN,DIVRREC)
- QUIT
- +1 if '$$VENTRY^DIEFU(DIVRFIIN,DIVRREC,"D")
- QUIT
- +2 NEW %,DEPTH,D,DS
- +3 SET DEPTH=$LENGTH(DIVRREC,",")-1
- +4 FOR %=1:1:DEPTH
- SET D="D"_(DEPTH-%)
- NEW @D
- SET @D=$PIECE(DIVRREC,",",%)
- +5 SET DS=DEPTH
- DO DIVRDR
- +6 QUIT
- DIVRDR NEW FLD,PC,Z,END,OUT,F,Y,Q,S
- +1 SET F=1
- SET FLD=0
- SET Q=""""
- SET S=";"
- +2 if $GET(DIVRDR)=""
- SET DIVRDR="ALL"
- +3 IF DIVRDR="ALL"
- Begin DoDot:1
- +4 FOR
- SET FLD=$ORDER(^DD(DIVRFILE,FLD))
- if FLD'>0
- QUIT
- DO SET
- if $DATA(DIRUT)
- QUIT
- End DoDot:1
- QUIT
- +5 FOR
- SET Z=$GET(Z)+1
- SET PC=$PIECE(DIVRDR,S,Z)
- if PC=""
- QUIT
- Begin DoDot:1
- +6 NEW Z
- +7 IF PC[":"
- SET FLD=$ORDER(^DD(DIVRFILE,+PC),-1)
- SET END=+$PIECE(PC,":",2)
- Begin DoDot:2
- +8 FOR
- SET FLD=$ORDER(^DD(DIVRFILE,FLD))
- if FLD'>0!(FLD>END)
- QUIT
- DO SET
- if $DATA(DIRUT)
- QUIT
- End DoDot:2
- QUIT
- +9 SET FLD=PC
- IF $$VFIELD^DILFD(DIVRFILE,PC,"D")
- DO SET
- QUIT
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- +10 QUIT
- SET NEW TYP,IT,T,W,PC3,M,Y,KEY
- +1 SET Y=FLD
- SET Y(0)=^DD(DIVRFILE,FLD,0)
- SET TYP=$PIECE(Y(0),U,2)
- SET IT=$PIECE(Y(0),U,5,99)
- SET PC3=$PIECE(Y(0),U,3)
- +2 FOR T="N","D","P","S","V","F"
- if TYP[T
- QUIT
- +3 FOR W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K"
- IF T[$EXTRACT(W)
- if W="K"
- SET W="MUMPS"
- QUIT
- +4 IF TYP["C"
- QUIT
- +5 IF TYP
- IF $PIECE(^DD(+TYP,.01,0),U,2)["W"
- QUIT
- +6 IF TYP
- DO MULT
- QUIT
- +7 IF 'R
- if $Y>(IOSL-4)
- DO FF
- if $DATA(DIRUT)
- QUIT
- WRITE !!?TAB,$PIECE(^DD(DIVRFILE,FLD,0),U)_" (#"_FLD_")",?40,W
- +8 IF TYP["*"
- IF TYP'["X"
- SET IT="Q"
- IF $DATA(^DD(DIVRFILE,FLD,12.1))
- XECUTE ^(12.1)
- IF $DATA(DIC("S"))
- SET IT(1)=DIC("S")
- SET IT="X IT(1) E K X"
- +9 SET KEY=$DATA(^DD("KEY","F",DIVRFILE,FLD))>9
- +10 DO XDE
- +11 QUIT
- XDE IF F
- Begin DoDot:1
- +1 IF R
- IF DIVRFILE=DIVRFIIN
- SET DE="D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)"
- QUIT
- +2 DO DE^DIVU(DIVRFILE,"","","DE",$GET(DS)_U_$GET(DS))
- SET F=0
- SET DE=DE_" D DA^DIVU(.DA) X DE(99) G Q:$G(DIRUT)"
- QUIT
- End DoDot:1
- +3 DO DE99(DIVRFILE,FLD)
- +4 XECUTE DE
- +5 QUIT
- MULT if $Y>(IOSL-4)
- DO FF
- if $DATA(DIRUT)
- QUIT
- +1 if 'R
- WRITE !!?TAB,$PIECE(^DD(DIVRFILE,FLD,0),U)_"(#"_FLD_") --multiple--"
- +2 NEW DIVRFILE,FLD,DA,V,I,J,K,F,DE
- +3 SET DIVRFILE=+TYP
- SET FLD=0
- SET TAB=TAB+2
- SET F=1
- DO IJ^DIVU(DIVRFILE)
- +4 FOR
- SET FLD=$ORDER(^DD(DIVRFILE,FLD))
- if FLD'>0
- QUIT
- DO SET
- if $DATA(DIRUT)
- QUIT
- +5 SET TAB=TAB-2
- KILL @("D"_V)
- +6 QUIT
- R IF X?." "
- if TYP'["R"&'KEY
- QUIT
- Begin DoDot:1
- +1 IF X=""
- SET M="Missing"_$SELECT(KEY:" key value",1:"")
- +2 IF '$TEST
- SET M="Equals only 1 or more spaces"
- +3 DO X
- End DoDot:1
- QUIT
- +4 DO @T
- QUIT
- P IF @("$D(^"_PC3_"X,0))")
- DO F
- QUIT
- +1 SET M="No '"_X_"' in pointed-to File"
- DO X
- QUIT
- V IF $PIECE(X,S,2)'?1A.AN1"(".ANP
- IF $PIECE(X,S,2)'?1"%".AN1"(".ANP
- SET M=Q_X_Q_" has the wrong format"
- DO X
- QUIT
- +1 SET M=$SELECT($DATA(@(U_$PIECE(X,S,2)_"0)")):^(0),1:"")
- +2 IF '$DATA(^DD(DIVRFILE,FLD,"V","B",+$PIECE(M,U,2)))
- SET M=$PIECE(M,U)_" FILE not in the DD"
- DO X
- QUIT
- +3 IF '$DATA(@(U_$PIECE(X,S,2)_+X_",0)"))
- SET M=U_$PIECE(X,S,2)_+X_",0) does not exist"
- DO X
- QUIT
- +4 DO F
- QUIT
- S SET Y=X
- IF TYP'["X"
- XECUTE IT
- IF '$DATA(X)
- SET M=Q_Y_Q_" fails screen"
- DO X
- QUIT
- +1 if S_PC3[(S_X_"
- QUIT
- SET M=Q_X_Q_" not in Set"
- DO X
- QUIT
- D NEW Y,%DT
- SET Y=$FIND(IT,"%DT=""E")
- if Y
- SET IT=$EXTRACT(IT,1,Y-2)_$EXTRACT(IT,Y,999)
- +1 IF TYP["X"
- XECUTE $PIECE(IT," D ^%DT")
- DO ^%DT
- IF Y<0
- SET M="Invalid date"
- DO X
- QUIT
- +2 DO F
- QUIT
- N IF TYP["X"
- IF X'?.1"-".N.".".N
- SET M="Invalid number"
- DO X
- QUIT
- +1 DO F
- QUIT
- K DO ^DIM
- IF '$DATA(X)
- SET M="Invalid M code"
- DO X
- +1 QUIT
- F NEW Y
- SET Y=X
- IF X'?.ANP
- SET M="Non-printing character"
- DO X
- IT if TYP["X"
- QUIT
- Begin DoDot:1
- +1 NEW %Y
- SET %Y=Y
- XECUTE IT
- SET Y=%Y
- End DoDot:1
- if $DATA(X)
- QUIT
- SET M=Q_Y_Q_" fails Input Transform"
- +2 ;
- X SET X=$SELECT(V:DA(V),1:DA)
- SET ^TMP("DIVR1",$JOB,$SELECT('R:X,$GET(DIVRREC)["[":X,(R&($GET(DIVROUT)["[")):X,1:DIVRREC))=""
- SET X=V
- SET Z=0
- +1 IF @(I(0)_"0)")
- IEN if $Y>(IOSL-3)
- DO FF
- if $DATA(DIRUT)
- QUIT
- +1 IF 'R
- Begin DoDot:1
- +2 FOR
- if 'X
- QUIT
- WRITE !?5,@("D"_Z),?15,$PIECE(^(@("D"_Z),0),U)
- SET X=X-1
- SET Z=Z+1
- SET @("Y=$D(^("_I(V-X)_",0))")
- +3 WRITE !?5,@("D"_Z),?15,$SELECT($DATA(^(@("D"_Z),0)):$PIECE(^(0),U),1:@("D"_Z)),?50,$EXTRACT(M,1,40)
- if V
- WRITE !
- End DoDot:1
- QUIT
- +4 IF R
- Begin DoDot:1
- +5 FOR
- if 'X
- QUIT
- WRITE !,@("D"_Z),?10,$PIECE(^(@("D"_Z),0),U)
- if Z
- WRITE " (",K(Z),")"
- SET X=X-1
- SET Z=Z+1
- SET @("Y=$D(^("_I(V-X)_",0))")
- +6 WRITE !,@("D"_Z),?10,$SELECT($DATA(^(@("D"_Z),0)):$PIECE(^(0),U),1:@("D"_Z))
- if Z
- WRITE " (",K(Z),")"
- WRITE !?5,$PIECE(^DD(DIVRFILE,FLD,0),U)," (#",FLD,")",?35,W,?50,M
- if V
- WRITE !
- End DoDot:1
- QUIT
- +7 QUIT
- +8 ;
- DE99(FI,FD,NP) ;
- +1 NEW Y
- +2 DO GET^DIOU(FI,FD,"X",.Y,"I")
- +3 SET DE(99)=Y_" D R "
- QUIT
- +4 QUIT
- Q DO ^%ZISC
- +1 QUIT
- FF IF IOST["C-"
- NEW DIR,X,Y
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +1 IF R
- DO H2
- QUIT
- H1 if $Y
- WRITE @IOF
- WRITE "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25)
- WRITE DATE
- WRITE ?(IOM-9),"PAGE ",PG+1
- +1 WRITE !,"Field Name (Field #)",?40,"Type"
- +2 WRITE !?5,"Entry #",?15,"Name",?50,"ERROR"
- +3 NEW L
- WRITE !
- FOR L=1:1:(IOM-2)
- WRITE "-"
- +4 SET PG=PG+1
- +5 QUIT
- H2 if $Y
- WRITE @IOF
- WRITE "Verify Fields File: ",DIVRFI0_" "_DIVRFINM,?(IOM-25)
- WRITE DATE
- WRITE ?(IOM-9),"PAGE ",PG+1
- +1 WRITE !,"Entry #",?10,"Name"
- +2 WRITE !?5,"Field Name (Field #)",?35,"Type",?50,"ERROR"
- +3 NEW L
- WRITE !
- FOR L=1:1:(IOM-2)
- WRITE "-"
- +4 SET PG=PG+1
- +5 QUIT
