source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m@ 808

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