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 Dec 13, 2024@02:54:47 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
