Changeset 623 for WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m (modified) (1 diff)

WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m

@@ -1 @@
-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
+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