- 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
