- YTQPRT ;ASF/ALB MHA3 PRINT TEST; 2/24/10 1:27pm
- ;;5.01;MENTAL HEALTH;**85,97,119**;DEC 30,1994;Build 40
- ;
- Q
- FORM ;print for clinicians
- N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN,YSLFT
- N DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
- N YTTLKUP S YTTLKUP=1 ; suppress filter
- K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
- S YSCODEN=+Y,YSCODE=$P(Y,U,2)
- ;S DA=YSCODEN D EN^DIQ
- D ^%ZIS Q:POP
- FA W @IOF,!?7,YSCODE
- W !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
- S YSNUMB=0,YSLFT=""
- ;Loop thru test for all items
- S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0!(YSLFT) S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0!(YSLFT) S YSNUMB=YSNUMB+1,YSR=0 D
- . D:(($Y+5)>IOSL) WAIT
- . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2)),YSRTYPE=$P(YSQG2,U,2)
- . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
- . D QOUT
- . W:YSRTYPE'=1 !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
- . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;-->out
- . S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) S:YSIDENT'="" YSIDENT=$P($G(^YTT(601.89,YSIDENT,0)),U,2)
- . S YSI=0 S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 S YSI=YSI+1 D
- .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
- ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
- ... W !,"_____ ",$S(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
- K ^TMP($J,"YSG")
- D ^%ZISC
- Q
- QOUT ;pull text and intros
- W !! ;,YSEQ,">> Question#"_YSQN
- S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
- I YSINTRO?1N.N S N1=0 F S N1=$O(^YTT(601.73,YSINTRO,1,N1)) Q:N1'>0 W !,^YTT(601.73,YSINTRO,1,N1,0)
- W !,YSNUMB,". " S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W:N1>1 ! W ^YTT(601.72,YSQN,1,N1,0)
- Q
- PRTTEST ;print for developers
- N YTTLKUP S YTTLKUP=1 ; suppress filter
- K DIC S DIC(0)="MAE",DIC="^YTT(601.71," D ^DIC Q:Y'>0
- N YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
- N DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP,YSLFT,YSRPT
- EN1 ;
- I '$G(YTTLKUP) N YTTLKUP S YTTLKUP=1 ; suppress filter
- K IOP S %ZIS="Q" D ^%ZIS Q:POP ;-->out
- S YSCODEN=+Y,YSCODE=$P(^YTT(601.71,YSCODEN,0),U)
- W @IOF,!?10,"*** ",YSCODE," ***",!
- S DA=YSCODEN,DIC="^YTT(601.71," D EN^DIQ
- S YSNUMB=0,YSLFT=""
- D:(($Y+9)>IOSL) WAIT
- Q:YSLFT
- ;Loop thru test for all items
- S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSCODEN,YSEQ)) Q:YSEQ'>0!(YSLFT) S YSIEN=$O(^YTT(601.76,"AD",YSCODEN,YSEQ,0)) Q:YSIEN'>0!(YSLFT) S YSNUMB=YSNUMB+1,YSR=0 D
- . D:(($Y+5)>IOSL) WAIT
- . S YSG=^YTT(601.76,YSIEN,0),YSQN=$P(YSG,U,4),YSQG2=$G(^YTT(601.72,YSQN,2))
- . S YSQDISP=$P(YSG,U,6),YSIDISP=$P(YSG,U,7),YSCDISP=$P(YSG,U,8)
- . D GETTEXT
- . S YSCTYPE=$P(YSQG2,U,3) Q:YSCTYPE="" ;->out
- . W !,"Choicetype: ",YSCTYPE
- . W " identifier: " I $D(^YTT(601.89,"B",YSCTYPE)) S YSIDENT=$O(^YTT(601.89,"B",YSCTYPE,0)) Q:YSIDENT="" W $P($G(^YTT(601.89,YSIDENT,0)),U,2)
- . D IENCK(YSCTYPE)
- . S YSCHTSEQ=0 F S YSCHTSEQ=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ)) Q:YSCHTSEQ'>0 D
- .. S YSCHOICE=$O(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0)) Q:YSCHOICE'>0 D
- ... S YSCTEXT=$G(^YTT(601.75,YSCHOICE,1))
- ... S YSLEG=$P($G(^YTT(601.75,YSCHOICE,0)),U,2)
- ... W !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
- Q:YSLFT ;-->out
- D SCALES
- Q:YSLFT ;-->out
- D SKIP
- Q:YSLFT ;-->out
- D RULESKIP
- Q:YSLFT ;-->out
- D REPORT
- K ^TMP($J,"YSG")
- D ^%ZISC
- Q
- GETTEXT ;pull text and intros
- W !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
- S YSINTRO=$P($G(^YTT(601.72,YSQN,2)),U)
- I YSINTRO?1N.N W !,"Intro #"_YSINTRO S N1=0 F S N1=$O(^YTT(601.73,YSINTRO,1,N1)) Q:N1'>0 W !,^YTT(601.73,YSINTRO,1,N1,0)
- S N1=0 F S N1=$O(^YTT(601.72,YSQN,1,N1)) Q:N1'>0 W !,^YTT(601.72,YSQN,1,N1,0)
- Q
- SCALES ;scales
- W !!!?5,"*** Scales ***",!
- S YS1("CODE")=YSCODE D SCALEG^YTQAPI3(.YSZ,.YS1)
- S N=1 F S N=$O(^TMP($J,"YSG",N)) Q:N'>0!(YSLFT) D
- . D:(($Y+9)>IOSL) WAIT
- . S G=^TMP($J,"YSG",N)
- . I G'?1"Scale".E W !,"scale group: ",+$P(G,"=",2)," ",$P(G,U,3) Q
- . S YSSCALE=$P(G,U,4),YSSCIEN=$P($P(G,U,1),"=",2)
- . W !,YSSCIEN,?10,YSSCALE
- . Q:'$D(^YTT(601.91,"AC",YSSCIEN))
- . W !?5,"# Question target ADD"
- . S J=0 F S J=$O(^YTT(601.91,"AC",YSSCIEN,J)) Q:J'>0 S G=^YTT(601.91,J,0) W !?5,+G,?12,$P(G,U,3)," ",$P(G,U,4)," ",$P(G,U,5)
- K ^TMP($J,"YSG")
- Q
- SKIP ;skip questions
- W !!!?5,"*** Skips ***",!
- S N=0 F S N=$O(^YTT(601.79,"AC",YSCODEN,N)) Q:N'>0!(YSLFT) D
- . D:(($Y+9)>IOSL) WAIT
- .S G=^YTT(601.79,N,0)
- . W !,"SkipID: "+$P(G,U)_" RuleId: "_$P(G,U,3)_" QuestionID: "_$P(G,U,4)
- .S ^TMP($J,"YSG",$P(G,U,3))=""
- Q
- RULESKIP ;rules that skip questions
- S N=0 F S N=$O(^TMP($J,"YSG",N)) Q:N'>1!(YSLFT) D
- . D:(($Y+9)>IOSL) WAIT
- . W !
- . S DA=N,DIC="^YTT(601.82," D EN^DIQ
- Q
- REPORT ;display report setup
- S YSRPT=$O(^YTT(601.93,"C",YSCODEN,0))
- I YSRPT'>0 W !!,"REPORT: not defined",!! Q ;-->out
- W !!
- S DA=YSRPT,DIC="^YTT(601.93," D EN^DIQ
- Q
- IENCK(NN) ;check ien< 100,000
- Q:YSCODEN>99999 ;-->out
- ; No national numbers left for 601.751, also not a DINUM'd file -- KCM
- ; S J=0 F S J=$O(^YTT(601.751,"B",NN,J)) Q:J'>0 I J>99999 W !,"###### not national ######## ",^YTT(601.751,J,0) S ^TMP($J,"YSNATERR",NN,YSCODE)=""
- Q
- WAIT ;
- F I0=1:1:IOSL-$Y-4 W !
- N DTOUT,DUOUT,DIRUT
- I IOST?1"C".E S DIR(0)="E" D ^DIR K DIR S YSLFT=$D(DIRUT)
- W @IOF Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPRT 5682 printed Jan 18, 2025@03:19:38 Page 2
- YTQPRT ;ASF/ALB MHA3 PRINT TEST; 2/24/10 1:27pm
- +1 ;;5.01;MENTAL HEALTH;**85,97,119**;DEC 30,1994;Build 40
- +2 ;
- +3 QUIT
- FORM ;print for clinicians
- +1 NEW YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN,YSLFT
- +2 NEW DA,G,J,N,N1,Y,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP
- +3 ; suppress filter
- NEW YTTLKUP
- SET YTTLKUP=1
- +4 KILL DIC
- SET DIC(0)="MAE"
- SET DIC="^YTT(601.71,"
- DO ^DIC
- if Y'>0
- QUIT
- +5 SET YSCODEN=+Y
- SET YSCODE=$PIECE(Y,U,2)
- +6 ;S DA=YSCODEN D EN^DIQ
- +7 DO ^%ZIS
- if POP
- QUIT
- FA WRITE @IOF,!?7,YSCODE
- +1 WRITE !,$$GET1^DIQ(601.71,YSCODEN_",","PRINT TITLE")
- +2 SET YSNUMB=0
- SET YSLFT=""
- +3 ;Loop thru test for all items
- +4 SET YSEQ=0
- FOR
- SET YSEQ=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ))
- if YSEQ'>0!(YSLFT)
- QUIT
- SET YSIEN=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ,0))
- if YSIEN'>0!(YSLFT)
- QUIT
- SET YSNUMB=YSNUMB+1
- SET YSR=0
- Begin DoDot:1
- +5 if (($Y+5)>IOSL)
- DO WAIT
- +6 SET YSG=^YTT(601.76,YSIEN,0)
- SET YSQN=$PIECE(YSG,U,4)
- SET YSQG2=$GET(^YTT(601.72,YSQN,2))
- SET YSRTYPE=$PIECE(YSQG2,U,2)
- +7 SET YSQDISP=$PIECE(YSG,U,6)
- SET YSIDISP=$PIECE(YSG,U,7)
- SET YSCDISP=$PIECE(YSG,U,8)
- +8 DO QOUT
- +9 if YSRTYPE'=1
- WRITE !,$$GET1^DIQ(601.74,YSRTYPE_",",1)_":__________"
- +10 ;-->out
- SET YSCTYPE=$PIECE(YSQG2,U,3)
- if YSCTYPE=""
- QUIT
- +11 SET YSIDENT=$ORDER(^YTT(601.89,"B",YSCTYPE,0))
- if YSIDENT'=""
- SET YSIDENT=$PIECE($GET(^YTT(601.89,YSIDENT,0)),U,2)
- +12 SET YSI=0
- SET YSCHTSEQ=0
- FOR
- SET YSCHTSEQ=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ))
- if YSCHTSEQ'>0
- QUIT
- SET YSI=YSI+1
- Begin DoDot:2
- +13 SET YSCHOICE=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0))
- if YSCHOICE'>0
- QUIT
- Begin DoDot:3
- +14 SET YSCTEXT=$GET(^YTT(601.75,YSCHOICE,1))
- +15 WRITE !,"_____ ",$SELECT(YSIDENT=0:YSI-1_".",YSIDENT="N":"",1:YSI_".")," ",YSCTEXT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 KILL ^TMP($JOB,"YSG")
- +17 DO ^%ZISC
- +18 QUIT
- QOUT ;pull text and intros
- +1 ;,YSEQ,">> Question#"_YSQN
- WRITE !!
- +2 SET YSINTRO=$PIECE($GET(^YTT(601.72,YSQN,2)),U)
- +3 IF YSINTRO?1N.N
- SET N1=0
- FOR
- SET N1=$ORDER(^YTT(601.73,YSINTRO,1,N1))
- if N1'>0
- QUIT
- WRITE !,^YTT(601.73,YSINTRO,1,N1,0)
- +4 WRITE !,YSNUMB,". "
- SET N1=0
- FOR
- SET N1=$ORDER(^YTT(601.72,YSQN,1,N1))
- if N1'>0
- QUIT
- if N1>1
- WRITE !
- WRITE ^YTT(601.72,YSQN,1,N1,0)
- +5 QUIT
- PRTTEST ;print for developers
- +1 ; suppress filter
- NEW YTTLKUP
- SET YTTLKUP=1
- +2 KILL DIC
- SET DIC(0)="MAE"
- SET DIC="^YTT(601.71,"
- DO ^DIC
- if Y'>0
- QUIT
- +3 NEW YSLIMIT,YSCODE,YSCODEN,YSNUMB,YSG,YSIEN,YSOPER,YSQG2,YSERR,YSCTYPE,YSCHT,YSCHOICE,YSLEG,YSQN,YSNN
- +4 NEW DA,G,J,N,N1,YS1,YSCDISP,YSCHTSEQ,YSCTEXT,YSI,YSIDENT,YSDISP,YSINTRO,YSQDISP,YSR,YSRTYPE,YSSCALE,YSSCIEN,YSZ,YSEQ,YSIDISP,YSLFT,YSRPT
- EN1 ;
- +1 ; suppress filter
- IF '$GET(YTTLKUP)
- NEW YTTLKUP
- SET YTTLKUP=1
- +2 ;-->out
- KILL IOP
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +3 SET YSCODEN=+Y
- SET YSCODE=$PIECE(^YTT(601.71,YSCODEN,0),U)
- +4 WRITE @IOF,!?10,"*** ",YSCODE," ***",!
- +5 SET DA=YSCODEN
- SET DIC="^YTT(601.71,"
- DO EN^DIQ
- +6 SET YSNUMB=0
- SET YSLFT=""
- +7 if (($Y+9)>IOSL)
- DO WAIT
- +8 if YSLFT
- QUIT
- +9 ;Loop thru test for all items
- +10 SET YSEQ=0
- FOR
- SET YSEQ=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ))
- if YSEQ'>0!(YSLFT)
- QUIT
- SET YSIEN=$ORDER(^YTT(601.76,"AD",YSCODEN,YSEQ,0))
- if YSIEN'>0!(YSLFT)
- QUIT
- SET YSNUMB=YSNUMB+1
- SET YSR=0
- Begin DoDot:1
- +11 if (($Y+5)>IOSL)
- DO WAIT
- +12 SET YSG=^YTT(601.76,YSIEN,0)
- SET YSQN=$PIECE(YSG,U,4)
- SET YSQG2=$GET(^YTT(601.72,YSQN,2))
- +13 SET YSQDISP=$PIECE(YSG,U,6)
- SET YSIDISP=$PIECE(YSG,U,7)
- SET YSCDISP=$PIECE(YSG,U,8)
- +14 DO GETTEXT
- +15 ;->out
- SET YSCTYPE=$PIECE(YSQG2,U,3)
- if YSCTYPE=""
- QUIT
- +16 WRITE !,"Choicetype: ",YSCTYPE
- +17 WRITE " identifier: "
- IF $DATA(^YTT(601.89,"B",YSCTYPE))
- SET YSIDENT=$ORDER(^YTT(601.89,"B",YSCTYPE,0))
- if YSIDENT=""
- QUIT
- WRITE $PIECE($GET(^YTT(601.89,YSIDENT,0)),U,2)
- +18 DO IENCK(YSCTYPE)
- +19 SET YSCHTSEQ=0
- FOR
- SET YSCHTSEQ=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ))
- if YSCHTSEQ'>0
- QUIT
- Begin DoDot:2
- +20 SET YSCHOICE=$ORDER(^YTT(601.751,"AC",YSCTYPE,YSCHTSEQ,0))
- if YSCHOICE'>0
- QUIT
- Begin DoDot:3
- +21 SET YSCTEXT=$GET(^YTT(601.75,YSCHOICE,1))
- +22 SET YSLEG=$PIECE($GET(^YTT(601.75,YSCHOICE,0)),U,2)
- +23 WRITE !,"# "_YSCHOICE_" Leg: "_YSLEG_" "_YSCTEXT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 ;-->out
- if YSLFT
- QUIT
- +25 DO SCALES
- +26 ;-->out
- if YSLFT
- QUIT
- +27 DO SKIP
- +28 ;-->out
- if YSLFT
- QUIT
- +29 DO RULESKIP
- +30 ;-->out
- if YSLFT
- QUIT
- +31 DO REPORT
- +32 KILL ^TMP($JOB,"YSG")
- +33 DO ^%ZISC
- +34 QUIT
- GETTEXT ;pull text and intros
- +1 WRITE !!,"<<",YSEQ,">> Question#"_YSQN," Display Q: ",YSQDISP," I: ",YSIDISP," C: ",YSCDISP
- +2 SET YSINTRO=$PIECE($GET(^YTT(601.72,YSQN,2)),U)
- +3 IF YSINTRO?1N.N
- WRITE !,"Intro #"_YSINTRO
- SET N1=0
- FOR
- SET N1=$ORDER(^YTT(601.73,YSINTRO,1,N1))
- if N1'>0
- QUIT
- WRITE !,^YTT(601.73,YSINTRO,1,N1,0)
- +4 SET N1=0
- FOR
- SET N1=$ORDER(^YTT(601.72,YSQN,1,N1))
- if N1'>0
- QUIT
- WRITE !,^YTT(601.72,YSQN,1,N1,0)
- +5 QUIT
- SCALES ;scales
- +1 WRITE !!!?5,"*** Scales ***",!
- +2 SET YS1("CODE")=YSCODE
- DO SCALEG^YTQAPI3(.YSZ,.YS1)
- +3 SET N=1
- FOR
- SET N=$ORDER(^TMP($JOB,"YSG",N))
- if N'>0!(YSLFT)
- QUIT
- Begin DoDot:1
- +4 if (($Y+9)>IOSL)
- DO WAIT
- +5 SET G=^TMP($JOB,"YSG",N)
- +6 IF G'?1"Scale".E
- WRITE !,"scale group: ",+$PIECE(G,"=",2)," ",$PIECE(G,U,3)
- QUIT
- +7 SET YSSCALE=$PIECE(G,U,4)
- SET YSSCIEN=$PIECE($PIECE(G,U,1),"=",2)
- +8 WRITE !,YSSCIEN,?10,YSSCALE
- +9 if '$DATA(^YTT(601.91,"AC",YSSCIEN))
- QUIT
- +10 WRITE !?5,"# Question target ADD"
- +11 SET J=0
- FOR
- SET J=$ORDER(^YTT(601.91,"AC",YSSCIEN,J))
- if J'>0
- QUIT
- SET G=^YTT(601.91,J,0)
- WRITE !?5,+G,?12,$PIECE(G,U,3)," ",$PIECE(G,U,4)," ",$PIECE(G,U,5)
- End DoDot:1
- +12 KILL ^TMP($JOB,"YSG")
- +13 QUIT
- SKIP ;skip questions
- +1 WRITE !!!?5,"*** Skips ***",!
- +2 SET N=0
- FOR
- SET N=$ORDER(^YTT(601.79,"AC",YSCODEN,N))
- if N'>0!(YSLFT)
- QUIT
- Begin DoDot:1
- +3 if (($Y+9)>IOSL)
- DO WAIT
- +4 SET G=^YTT(601.79,N,0)
- +5 WRITE !,"SkipID: "+$PIECE(G,U)_" RuleId: "_$PIECE(G,U,3)_" QuestionID: "_$PIECE(G,U,4)
- +6 SET ^TMP($JOB,"YSG",$PIECE(G,U,3))=""
- End DoDot:1
- +7 QUIT
- RULESKIP ;rules that skip questions
- +1 SET N=0
- FOR
- SET N=$ORDER(^TMP($JOB,"YSG",N))
- if N'>1!(YSLFT)
- QUIT
- Begin DoDot:1
- +2 if (($Y+9)>IOSL)
- DO WAIT
- +3 WRITE !
- +4 SET DA=N
- SET DIC="^YTT(601.82,"
- DO EN^DIQ
- End DoDot:1
- +5 QUIT
- REPORT ;display report setup
- +1 SET YSRPT=$ORDER(^YTT(601.93,"C",YSCODEN,0))
- +2 ;-->out
- IF YSRPT'>0
- WRITE !!,"REPORT: not defined",!!
- QUIT
- +3 WRITE !!
- +4 SET DA=YSRPT
- SET DIC="^YTT(601.93,"
- DO EN^DIQ
- +5 QUIT
- IENCK(NN) ;check ien< 100,000
- +1 ;-->out
- if YSCODEN>99999
- QUIT
- +2 ; No national numbers left for 601.751, also not a DINUM'd file -- KCM
- +3 ; S J=0 F S J=$O(^YTT(601.751,"B",NN,J)) Q:J'>0 I J>99999 W !,"###### not national ######## ",^YTT(601.751,J,0) S ^TMP($J,"YSNATERR",NN,YSCODE)=""
- +4 QUIT
- WAIT ;
- +1 FOR I0=1:1:IOSL-$Y-4
- WRITE !
- +2 NEW DTOUT,DUOUT,DIRUT
- +3 IF IOST?1"C".E
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET YSLFT=$DATA(DIRUT)
- +4 WRITE @IOF
- QUIT