YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97 17:09
;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
;
MAIN ;
K ^UTILITY($J,"W")
S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200
D R1
D PRT
Q
R1 ;
F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0)) D R2
Q
R2 ;
S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2)
I YSITEM=0 S R="" X YSEXE D STEM Q
I YSEXE="L"!(YSEXE="'L") D LISTER Q
S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X")
S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R=""
D STEM
Q
STEM ;
S YSSTEM=$P(A,U,2)
I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q
S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q
S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L
Q
END ;
K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
LISTER ;list formated output
K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y")
; check at list begining
S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q
S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
S R=$E(YSYX,YSITEM-L)
S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3)
D LIST1
I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q
I YSTL=1 S R=B1(1) D STEM Q
I YSTL=2 S R=B1(1)_" and "_B1(2) D STEM Q
S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", "
S R=R_"and "_B1(YSTL) D STEM
Q
LIST1 S YSTLN=YSTLN+1,YSITEM=YSITEM+1
Q:'$D(^YTT(601,YSTEST,"Q",YSITEM))
S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2
S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
S R=$E(YSYX,YSITEM-L)
S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2)
G LIST1
L ;
D:YSYTX["{" PRO ;evaluate pronouns etc
I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP
I $L(YSYTX)>80 D
. S YSX1=YSYTX
. F I=$L(YSX1):-1:1 S Y1=$E(YSX1,I) I Y1=" "&(I<80) S X=$E(YSX1,1,I-1),YSX1=$E(YSX1,I+1,999),DIWL=0,DIWR=79 D ^DIWP Q
. I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP
Q
PRT ; Print output
S YSZZ=0
S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
W !,?53,"PRINTED",?64,"ENTERED",!
S N=0 F S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ D
. W !,^UTILITY($J,"W",0,N,0)
. D:$Y+4>IOSL WAIT
;
Q
WAIT ;
F I0=1:1:IOSL-$Y-2 W !
N DTOUT,DUOUT,DIRUT
I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT)
Q:YSZZ
W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
W !?53,"PRINTED",?64,"ENTERED",!
Q
PRO ;evaluate pronoun, possesive etc
F I=1:1:$L(YSYTX,"{") D
. S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}")
. Q:'P1!'P2
. S G=$E(YSYTX,P1+1,P2-2),G1=0
. S:G="Pro" G1=$S(YSSEX="F":"She",1:"He")
. S:G="pro" G1=$S(YSSEX="F":"she",1:"he")
. S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His")
. S:G="pos" G1=$S(YSSEX="F":"her",1:"his")
. S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.")
. S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)
. S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2)
. I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D
.. F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
.. S G1=X
. S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTDOMR1 3271 printed Oct 16, 2024@18:17:56 Page 2
YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97 17:09
+1 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
+2 ;
MAIN ;
+1 KILL ^UTILITY($JOB,"W")
+2 ; S YSJ=1,U1=0,L=-200,YSLCK=200
SET YSLFN=1
+3 DO R1
+4 DO PRT
+5 QUIT
R1 ;
+1 FOR YSJ=1:1
if '$DATA(^YTT(601,YSTEST,"G",1,1,YSJ,0))
QUIT
DO R2
+2 QUIT
R2 ;
+1 SET A=^YTT(601,YSTEST,"G",1,1,YSJ,0)
SET YSITEM=+$PIECE(A,U)
SET YSEXE=$PIECE($PIECE(A,U),";",2)
+2 IF YSITEM=0
SET R=""
XECUTE YSEXE
DO STEM
QUIT
+3 IF YSEXE="L"!(YSEXE="'L")
DO LISTER
QUIT
+4 SET L=(YSITEM-1)\200*200
SET U1=L+200
SET YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
+5 SET R=$EXTRACT(YSYX,YSITEM-L)
if R=" "!(R="X")
QUIT
+6 if "YN"[R
SET R=R="N"+1
SET R=$PIECE(A,U,R+2)
if R=""
QUIT
+7 DO STEM
+8 QUIT
STEM ;
+1 SET YSSTEM=$PIECE(A,U,2)
+2 IF YSSTEM'["#"
SET YSYTX=YSSTEM_R
DO L
QUIT
+3 SET A=$FIND(YSSTEM,"#")
IF A<3
SET YSYTX=R_$EXTRACT(YSSTEM,2,999)
DO L
QUIT
+4 SET YSYTX=$EXTRACT(YSSTEM,1,A-2)_R_$EXTRACT(YSSTEM,A,999)
DO L
+5 QUIT
END ;
+1 KILL I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK
QUIT
LISTER ;list formated output
+1 KILL B1
SET YSTL=0
SET YSTLN=1
SET YSCOMP=$SELECT(YSEXE="'L":"N",1:"Y")
+2 ; check at list begining
+3 SET YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1)
IF YSQTYP'=1
SET R="eRROR LINE "_YSJ
DO STEM
QUIT
+4 SET L=(YSITEM-1)\200*200
SET U1=L+200
SET YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
+5 SET R=$EXTRACT(YSYX,YSITEM-L)
+6 if R=YSCOMP
SET YSTL=YSTL+1
SET B1(YSTL)=$PIECE(A,U,3)
+7 DO LIST1
+8 IF 'YSTL
SET R=$PIECE(A,U,YSTLN+2)
DO STEM
QUIT
+9 IF YSTL=1
SET R=B1(1)
DO STEM
QUIT
+10 IF YSTL=2
SET R=B1(1)_" and "_B1(2)
DO STEM
QUIT
+11 SET R=""
FOR I=1:1:YSTL-1
SET R=R_B1(I)_", "
+12 SET R=R_"and "_B1(YSTL)
DO STEM
+13 QUIT
LIST1 SET YSTLN=YSTLN+1
SET YSITEM=YSITEM+1
+1 if '$DATA(^YTT(601,YSTEST,"Q",YSITEM))
QUIT
+2 SET YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1)
if YSQTYP'=2
QUIT
+3 SET L=(YSITEM-1)\200*200
SET U1=L+200
SET YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
+4 SET R=$EXTRACT(YSYX,YSITEM-L)
+5 if R=YSCOMP
SET YSTL=YSTL+1
SET B1(YSTL)=$PIECE(A,U,YSTLN+2)
+6 GOTO LIST1
L ;
+1 ;evaluate pronouns etc
if YSYTX["{"
DO PRO
+2 IF $LENGTH(YSYTX)<80
SET DIWL=0
SET DIWR=79
SET X=YSYTX
DO ^DIWP
+3 IF $LENGTH(YSYTX)>80
Begin DoDot:1
+4 SET YSX1=YSYTX
+5 FOR I=$LENGTH(YSX1):-1:1
SET Y1=$EXTRACT(YSX1,I)
IF Y1=" "&(I<80)
SET X=$EXTRACT(YSX1,1,I-1)
SET YSX1=$EXTRACT(YSX1,I+1,999)
SET DIWL=0
SET DIWR=79
DO ^DIWP
QUIT
+6 IF $LENGTH(YSX1)
IF YSX1'=" "
SET DIWL=0
SET DIWR=79
SET X=YSX1
DO ^DIWP
End DoDot:1
+7 QUIT
PRT ; Print output
+1 SET YSZZ=0
+2 SET YSHDR=$EXTRACT(YSHDR,1,43)_" "_YSSEX_" AGE "_$JUSTIFY(YSAGE,2,0)
+3 WRITE @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
+4 WRITE !,?53,"PRINTED",?64,"ENTERED",!
+5 SET N=0
FOR
SET N=$ORDER(^UTILITY($JOB,"W",0,N))
if N'>0!YSZZ
QUIT
Begin DoDot:1
+6 WRITE !,^UTILITY($JOB,"W",0,N,0)
+7 if $Y+4>IOSL
DO WAIT
End DoDot:1
+8 ;
+9 QUIT
WAIT ;
+1 FOR I0=1:1:IOSL-$Y-2
WRITE !
+2 NEW DTOUT,DUOUT,DIRUT
+3 IF IOST?1"C".E
WRITE $CHAR(7)
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET YSZZ=$DATA(DIRUT)
+4 if YSZZ
QUIT
+5 WRITE @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
+6 WRITE !?53,"PRINTED",?64,"ENTERED",!
+7 QUIT
PRO ;evaluate pronoun, possesive etc
+1 FOR I=1:1:$LENGTH(YSYTX,"{")
Begin DoDot:1
+2 SET P1=$FIND(YSYTX,"{")-1
SET P2=$FIND(YSYTX,"}")
+3 if 'P1!'P2
QUIT
+4 SET G=$EXTRACT(YSYTX,P1+1,P2-2)
SET G1=0
+5 if G="Pro"
SET G1=$SELECT(YSSEX="F":"She",1:"He")
+6 if G="pro"
SET G1=$SELECT(YSSEX="F":"she",1:"he")
+7 if G="Pos"
SET G1=$SELECT(YSSEX="F":"Her",1:"His")
+8 if G="pos"
SET G1=$SELECT(YSSEX="F":"her",1:"his")
+9 if G="Title"
SET G1=$SELECT(YSSEX="F":"Ms.",1:"Mr.")
+10 if G="DATE"
SET G1=$EXTRACT(YSED,4,5)_"/"_$EXTRACT(YSED,6,7)_"/"_$EXTRACT(YSED,2,3)
+11 if G="CLIN"
SET G1=$PIECE($GET(^VA(200,$PIECE(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2)
+12 IF G="Last"
SET X=$PIECE($PIECE(^DPT(YSDFN,0),U),",")
Begin DoDot:2
+13 FOR %=2:1:$LENGTH(X)
IF $EXTRACT(X,%)?1U
IF $EXTRACT(X,%-1)?1A
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)+32)_$EXTRACT(X,%+1,999)
+14 SET G1=X
End DoDot:2
+15 SET YSYTX=$EXTRACT(YSYTX,1,P1-1)_G1_$EXTRACT(YSYTX,P2,999)
End DoDot:1
+16 ;
+17 QUIT
