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

Last change on this file since 1806 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97 17:09
2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
3 ;
4MAIN ;
5 K ^UTILITY($J,"W")
6 S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200
7 D R1
8 D PRT
9 Q
10R1 ;
11 F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0)) D R2
12 Q
13R2 ;
14 S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2)
15 I YSITEM=0 S R="" X YSEXE D STEM Q
16 I YSEXE="L"!(YSEXE="'L") D LISTER Q
17 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
18 S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X")
19 S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R=""
20 D STEM
21 Q
22STEM ;
23 S YSSTEM=$P(A,U,2)
24 I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q
25 S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q
26 S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L
27 Q
28END ;
29 K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
30LISTER ;list formated output
31 K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y")
32 ; check at list begining
33 S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q
34 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
35 S R=$E(YSYX,YSITEM-L)
36 S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3)
37 D LIST1
38 I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q
39 I YSTL=1 S R=B1(1) D STEM Q
40 I YSTL=2 S R=B1(1)_" and "_B1(2) D STEM Q
41 S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", "
42 S R=R_"and "_B1(YSTL) D STEM
43 Q
44LIST1 S YSTLN=YSTLN+1,YSITEM=YSITEM+1
45 Q:'$D(^YTT(601,YSTEST,"Q",YSITEM))
46 S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2
47 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
48 S R=$E(YSYX,YSITEM-L)
49 S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2)
50 G LIST1
51L ;
52 D:YSYTX["{" PRO ;evaluate pronouns etc
53 I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP
54 I $L(YSYTX)>80 D
55 . S YSX1=YSYTX
56 . 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
57 . I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP
58 Q
59PRT ; Print output
60 S YSZZ=0
61 S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
62 W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
63 W !,?53,"PRINTED",?64,"ENTERED",!
64 S N=0 F S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ D
65 . W !,^UTILITY($J,"W",0,N,0)
66 . D:$Y+4>IOSL WAIT
67 ;
68 Q
69WAIT ;
70 F I0=1:1:IOSL-$Y-2 W !
71 N DTOUT,DUOUT,DIRUT
72 I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT)
73 Q:YSZZ
74 W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
75 W !?53,"PRINTED",?64,"ENTERED",!
76 Q
77PRO ;evaluate pronoun, possesive etc
78 F I=1:1:$L(YSYTX,"{") D
79 . S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}")
80 . Q:'P1!'P2
81 . S G=$E(YSYTX,P1+1,P2-2),G1=0
82 . S:G="Pro" G1=$S(YSSEX="F":"She",1:"He")
83 . S:G="pro" G1=$S(YSSEX="F":"she",1:"he")
84 . S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His")
85 . S:G="pos" G1=$S(YSSEX="F":"her",1:"his")
86 . S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.")
87 . S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)
88 . S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2)
89 . I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D
90 .. 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)
91 .. S G1=X
92 . S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999)
93 ;
94 Q
Note: See TracBrowser for help on using the repository browser.