INHUTSRD(DIR,DIRH,DIRT,DICHCS) ; ESS,JSH; 11 Apr 94 13:58; scrolling reader routine without key control - non SAIC-CARE version
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
;This routine is saved as UTSRD for pre version 4.2 & DHCP systems
;
N Q,DX,DY,%,Z,K
N DIRA,DIRB,DIRBS,DIRER,DIRHI,DIRLO,DIRTC,DIRF,DIRECHO,DIRL1,DIRL2,DIRWRAP
S:'$D(DTIME) DTIME=300 K DTOUT
A ;
N:$P(DIR,";",10)'="" X S Q=$P(DIR,";",14) S:Q]"" @Q=0
I $P(DIR,";",12) N DTIME S DTIME=$P(DIR,";",12)
S DIRF=$P(DIR,";",5),DIRECHO=$P(DIR,";",11)
;
S DIRL1=+$P(DIR,";",4),DIRL2=+$P($P(DIR,";",4),",",2),DIRL2=$S(DIRL2=0:254,DIRL2'?1.3N:254,1:DIRL2),DIRL3=+$P($P(DIR,";",4),",",3)
D:$P(DIR,";",13) FLUSH
I W $P(DIR,";") W:DIRF'="" DIRF_"// "
S DIRER=0 X:DIRECHO ^%ZOSF("EOFF")
R X#DIRL2+('DIRL3):DTIME E G TO
R1 G:X="^" Q1 G:X="^^" Q2
I X="" S X=DIRF W X G:DIRF'=""!'($P(DIR,";",8)) Q S DIRER=6 D ER G I
I $E(X)="?" G:$G(DIRH)=1 Q D D:DIRER ER G I
.I '$D(DIRH) S DIRER=8 D ER Q ;because of level can't just G ER
.I $E(DIRH)=U X $P(DIRH,U,2,99) W ! Q
.I $D(DIRH)<9 W !,$S($G(DIRH)]"":DIRH,1:"NO HELP AVAILABLE")
.F Z=1:1 Q:'$D(DIRH(Z))#2 W !,DIRH(Z)
.W !
X $P($G(DIR),";",9) I '$D(X) S DIRER=1 D ER G I
I $P(DIR,";",2)'="" X "I X?"_$P(DIR,";",2) E S DIRER=1 D ER G I
I $P(DIR,";",6)'="" S DIRLO=$P(DIR,";",6),DIRHI=+$P(DIRLO,",",2),DIRLO=+DIRLO I DIRLO>+X!(DIRHI<+X) S DIRER=2 D ER G I
S DIRER=$S(DIRL2<$L(X):3,DIRL1>$L(X):4,1:0) I DIRER=3,DIRL3 G Q
I DIRER D ER G I
;
Q ;
X:$P(DIR,";",10)]"" "S ("_$P(DIR,";",10)_")=X"
X:DIRECHO ^%ZOSF("EON")
Q
Q1 S:Q]"" @Q=1 G Q
Q2 S:Q]"" @Q=3 G Q
TO S:Q]"" @Q=2 S DTOUT=1 G Q
;
;
;returns 1 for YES, 0 for NO, 0^0=^, 0^1=TIMED OUT
YN(DIR,DIRH) N D,P,X,DIRA,DIRB,DIRBS,DIRER,DIRHI,DIRLO,DIRTC,DIRF,DIRECHO,DX,DY
S P=$P(DIR,";"),DIRI=1 I P="",$P(DIR,";",2)["^" S P="Enter (Y/N):"
YN0 S D=$P(DIR,";",2),D=$S(D="":0,1:D#2+1),DIRMAX=3,DIRF=$S(D:$P("N^Y",U,D),1:""),DIRCP=1
YNA W:P]"" ! W P_$J("",4-$L(P)) W:DIRF]"" DIRF_"// " R X#3:DTIME Q:'$T "0^1"
;X ^%ZOSF("TRMRD") I Y'=0,Y'=13 S DIRER=1 D ER,FLUSH G YNA
YN1 I $E(X)="^" Q "0^0"
I $E(X)="?" Q:$G(DIRH) "0^?" S DIRER=9 D @$S($G(DIRH)]"":"H1",1:"ER") G YNA
S:X="" X=DIRF
S X=$E(X),X=$S("YyNn^"'[X:0,X=""&D:D,X="":0,"Yy"[X:2,"Nn"[X:1,1:0)
I 'X S DIRER=9 D ER G YNA
W " ",$P("(No)^(Yes)",U,X) Q X-1
H1 I $E($G(DIRH))=U X:$G(DIRECHO) ^%ZOSF("EON") X $P(DIRH,U,2,99) X:$G(DIRECHO) ^%ZOSF("EOFF") Q
W !,$S($G(DIRH)]"":$E(DIRH,1,78),1:"NO HELP AVAILABLE") Q
FLUSH N X X ^%ZOSF("EOFF") F R *X:0 Q:X=-1
X ^%ZOSF("EON") Q
;
CR() ;
CR0 R !,"Press <RETURN> to continue:",X#200:DTIME Q $E($G(X))="^"!'$T
;
MESS1(DIR) ;
N I,L S L=$L(DIR,"|")
F I=1:1:L W $P(DIR,"|",I) W:I<L !
W *7 R L#100:DTIME Q $E(L)="^"
;
ER W:$T(ER+DIRER)]"" !,$P($T(ER+DIRER),";",3),! W *7 Q
;;INVALID
;;ENTRY OUT OF RANGE
;;INPUT TOO LONG
;;INPUT TOO SHORT
;;TIMED OUT
;;THIS FIELD REQUIRED
;;HALT NOT ALLOWED
;;NO HELP AVAILABLE
;;ENTER YES OR NO
Q
INHUTSRD(DIR,DIRH,DIRT,DICHCS) ; ESS,JSH; 11 Apr 94 13:58; scrolling reader routine without key control - non SAIC-CARE version
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ;This routine is saved as UTSRD for pre version 4.2 & DHCP systems
+5 ;
+6 NEW Q,DX,DY,%,Z,K
+7 NEW DIRA,DIRB,DIRBS,DIRER,DIRHI,DIRLO,DIRTC,DIRF,DIRECHO,DIRL1,DIRL2,DIRWRAP
+8 IF '$DATA(DTIME)
SET DTIME=300
KILL DTOUT
A ;
+1 IF $PIECE(DIR,";",10)'=""
NEW X
SET Q=$PIECE(DIR,";",14)
IF Q]""
SET @Q=0
+2 IF $PIECE(DIR,";",12)
NEW DTIME
SET DTIME=$PIECE(DIR,";",12)
+3 SET DIRF=$PIECE(DIR,";",5)
SET DIRECHO=$PIECE(DIR,";",11)
+4 ;
+5 SET DIRL1=+$PIECE(DIR,";",4)
SET DIRL2=+$PIECE($PIECE(DIR,";",4),",",2)
SET DIRL2=$SELECT(DIRL2=0:254,DIRL2'?1.3N:254,1:DIRL2)
SET DIRL3=+$PIECE($PIECE(DIR,";",4),",",3)
+6 IF $PIECE(DIR,";",13)
DO FLUSH
I WRITE $PIECE(DIR,";")
IF DIRF'=""
WRITE DIRF_"// "
+1 SET DIRER=0
IF DIRECHO
XECUTE ^%ZOSF("EOFF")
+2 READ X#DIRL2+('DIRL3):DTIME
IF '$TEST
GOTO TO
R1 IF X="^"
GOTO Q1
IF X="^^"
GOTO Q2
+1 IF X=""
SET X=DIRF
WRITE X
IF DIRF'=""!'($PIECE(DIR,";",8))
GOTO Q
SET DIRER=6
DO ER
GOTO I
+2 IF $EXTRACT(X)="?"
IF $GET(DIRH)=1
GOTO Q
Begin DoDot:1
+3 ;because of level can't just G ER
IF '$DATA(DIRH)
SET DIRER=8
DO ER
QUIT
+4 IF $EXTRACT(DIRH)=U
XECUTE $PIECE(DIRH,U,2,99)
WRITE !
QUIT
+5 IF $DATA(DIRH)<9
WRITE !,$SELECT($GET(DIRH)]"":DIRH,1:"NO HELP AVAILABLE")
+6 FOR Z=1:1
IF '$DATA(DIRH(Z))#2
QUIT
WRITE !,DIRH(Z)
+7 WRITE !
End DoDot:1
IF DIRER
DO ER
GOTO I
+8 XECUTE $PIECE($GET(DIR),";",9)
IF '$DATA(X)
SET DIRER=1
DO ER
GOTO I
+9 IF $PIECE(DIR,";",2)'=""
XECUTE "I X?"_$PIECE(DIR,";",2)
IF '$TEST
SET DIRER=1
DO ER
GOTO I
+10 IF $PIECE(DIR,";",6)'=""
SET DIRLO=$PIECE(DIR,";",6)
SET DIRHI=+$PIECE(DIRLO,",",2)
SET DIRLO=+DIRLO
IF DIRLO>+X!(DIRHI<+X)
SET DIRER=2
DO ER
GOTO I
+11 SET DIRER=$SELECT(DIRL2<$LENGTH(X):3,DIRL1>$LENGTH(X):4,1:0)
IF DIRER=3
IF DIRL3
GOTO Q
+12 IF DIRER
DO ER
GOTO I
+13 ;
Q ;
+1 IF $PIECE(DIR,";",10)]""
XECUTE "S ("_$PIECE(DIR,";",10)_")=X"
+2 IF DIRECHO
XECUTE ^%ZOSF("EON")
+3 QUIT
Q1 IF Q]""
SET @Q=1
GOTO Q
Q2 IF Q]""
SET @Q=3
GOTO Q
TO IF Q]""
SET @Q=2
SET DTOUT=1
GOTO Q
+1 ;
+2 ;
+3 ;returns 1 for YES, 0 for NO, 0^0=^, 0^1=TIMED OUT
YN(DIR,DIRH) NEW D,P,X,DIRA,DIRB,DIRBS,DIRER,DIRHI,DIRLO,DIRTC,DIRF,DIRECHO,DX,DY
+1 SET P=$PIECE(DIR,";")
SET DIRI=1
IF P=""
IF $PIECE(DIR,";",2)["^"
SET P="Enter (Y/N):"
YN0 SET D=$PIECE(DIR,";",2)
SET D=$SELECT(D="":0,1:D#2+1)
SET DIRMAX=3
SET DIRF=$SELECT(D:$PIECE("N^Y",U,D),1:"")
SET DIRCP=1
YNA IF P]""
WRITE !
WRITE P_$JUSTIFY("",4-$LENGTH(P))
IF DIRF]""
WRITE DIRF_"// "
READ X#3:DTIME
IF '$TEST
QUIT "0^1"
+1 ;X ^%ZOSF("TRMRD") I Y'=0,Y'=13 S DIRER=1 D ER,FLUSH G YNA
YN1 IF $EXTRACT(X)="^"
QUIT "0^0"
+1 IF $EXTRACT(X)="?"
IF $GET(DIRH)
QUIT "0^?"
SET DIRER=9
DO @$SELECT($GET(DIRH)]"":"H1",1:"ER")
GOTO YNA
+2 IF X=""
SET X=DIRF
+3 SET X=$EXTRACT(X)
SET X=$SELECT("YyNn^"'[X:0,X=""&D:D,X="":0,"Yy"[X:2,"Nn"[X:1,1:0)
+4 IF 'X
SET DIRER=9
DO ER
GOTO YNA
+5 WRITE " ",$PIECE("(No)^(Yes)",U,X)
QUIT X-1
H1 IF $EXTRACT($GET(DIRH))=U
IF $GET(DIRECHO)
XECUTE ^%ZOSF("EON")
XECUTE $PIECE(DIRH,U,2,99)
IF $GET(DIRECHO)
XECUTE ^%ZOSF("EOFF")
QUIT
+1 WRITE !,$SELECT($GET(DIRH)]"":$EXTRACT(DIRH,1,78),1:"NO HELP AVAILABLE")
QUIT
FLUSH NEW X
XECUTE ^%ZOSF("EOFF")
FOR
READ *X:0
IF X=-1
QUIT
+1 XECUTE ^%ZOSF("EON")
QUIT
+2 ;
CR() ;
CR0 READ !,"Press <RETURN> to continue:",X#200:DTIME
QUIT $EXTRACT($GET(X))="^"!'$TEST
+1 ;
MESS1(DIR) ;
+1 NEW I,L
SET L=$LENGTH(DIR,"|")
+2 FOR I=1:1:L
WRITE $PIECE(DIR,"|",I)
IF I<L
WRITE !
+3 WRITE *7
READ L#100:DTIME
QUIT $EXTRACT(L)="^"
+4 ;
ER IF $TEXT(ER+DIRER)]""
WRITE !,$PIECE($TEXT(ER+DIRER),";",3),!
WRITE *7
QUIT
+1 ;;INVALID
+2 ;;ENTRY OUT OF RANGE
+3 ;;INPUT TOO LONG
+4 ;;INPUT TOO SHORT
+5 ;;TIMED OUT
+6 ;;THIS FIELD REQUIRED
+7 ;;HALT NOT ALLOWED
+8 ;;NO HELP AVAILABLE
+9 ;;ENTER YES OR NO
+10 QUIT
