Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YSASNAR

YSASNAR.m

Go to the documentation of this file.
  1. YSASNAR ;ALB/ASF,SLC/DKG,HIOFO/FT - ASI INTERVIEW REPORTER ;3/13/12 3:25 pm
  1. ;;5.01;MENTAL HEALTH;**24,30,37,38,44,55,67,76,103,60,187**;Dec 30, 1994;Build 73
  1. ;
  1. ;Reference to ^%ZISC supported by IA #10089
  1. ;Reference to ^%ZTLOAD supported by IA #10063
  1. ;Reference to HOME^%ZIS supported by IA #1008
  1. ;Reference to ^%ZIS supported by IA #10086
  1. ;Reference to $$GET1^DIQ() supported by IA #2056
  1. ;Reference to $$FMTE^XLFDT supported by IA #10103
  1. ;Reference to DEM^VADPT supported by IA #10061
  1. ;Reference to ^DIWP supported by IA #10011
  1. ;Reference to ^DIR supported by IA #10026
  1. ;Reference to ^DD("DD" supported by IA #10017
  1. ;Reference to ^VA(200 supported by IA #10060
  1. ;Reference to ^DPT( supported by IA #10035
  1. ;
  1. EN1(YSASDA) ;Entry point to display ASI
  1. Q:$G(YSASDA)'>0
  1. N YSASN,YSASNA,YSZZ,YSHDR,YSASD,YSAST,YSAS0,DIERR,YSI,YSASC,YSASN2
  1. ;ASK DEVICE
  1. N YSASQUIT,%ZIS,POP
  1. S %ZIS="QM"
  1. D ^%ZIS
  1. Q:$G(POP)
  1. I $D(IO("Q")) D Q
  1. .N ZTRTN,ZTDESC,ZTSAVE
  1. .S ZTRTN="QTEP^YSASNAR"
  1. .S ZTDESC="YSASPRT ASI NARRATIVE PRINT"
  1. .S ZTSAVE("YSASDA")=""
  1. .D ^%ZTLOAD W:$D(ZTSK) !!,"Your Task Number is "_ZTSK
  1. .D HOME^%ZIS
  1. .Q
  1. U IO
  1. QTEP ;Queued Task Entry Point
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. N G,G2,N,P1,P2,R,V,V1,Y1,YSA,YSAGE,YSAS0,YSASC,YSASD,YSASIG,YSASN,YSASNA,YSASQUIT,YSAST,YSASWP
  1. N YSASWP,YSBID,YSDOB,YSHDR,YSHIML,YSHIMU,YSI,YSJ,YSLAST,YSLCK,YSLFN,YSNM,YSPART,YSPOSL,YSPOSU
  1. N YSPROL,YSPROU,YSSC,YSSCK,YSSEX,YSSSN,YSSTEM,YSTITLE,YSX,YSYCK,YSYX,YSZ,YSZZ
  1. S YSZZ=0
  1. S YSAS0=^YSTX(604,YSASDA,0),DFN=$P(YSAS0,"^",2)
  1. D DEM^VADPT
  1. S YSASD=$$FMTE^XLFDT($P(YSAS0,U,5),"5ZD")
  1. S YSAST=$$GET1^DIQ(604,YSASDA_",",.04)
  1. S YSASC=$$GET1^DIQ(604,YSASDA_",",.09)
  1. S YSASIG=$$GET1^DIQ(604,YSASDA_",",.51,"I")
  1. S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN="xxx-xx-"_VA("BID"),YSBID=VA("BID")
  1. S YSHDR=VADM(1)_" "_"xxx-xx-"_YSBID_$J("",(20-$L(VADM(1))))_" ASI "_YSAST_" on "_YSASD_" by: "_YSASC
  1. ;
  1. MAIN ;
  1. K ^TMP($J,"YSTMP"),^TMP($J,"W")
  1. S YSLFN=1,^TMP($J,"YSTMP",0,1,0)=""
  1. D VARPRO
  1. D R1
  1. D SIG
  1. D PRT
  1. D ^%ZISC
  1. Q
  1. R1 ;
  1. S X=$S(YSAST?1"ASI-MV".E:"ASI-MV NARRATIVE",YSAST?1"FO".E:"FOLLOWUP NARRATIVE",1:"GENERAL"),YSPART=$O(^YSTX(604.68,"B",X,0))
  1. F YSJ=1:1 Q:'$D(^YSTX(604.68,YSPART,1,YSJ,0)) S YSA=^(0) D R2
  1. Q
  1. R2 ;
  1. I YSA?1"~".E Q
  1. I YSA?1"W{".E1"}" K YSWP S YSWP=$$GET1^DIQ(604,YSASDA_",",$E(YSA,3,$L(YSA)-1),"Z","YSWP") D:YSWP'="" K YSWP Q
  1. . S YSN2="" F S YSN2=$O(YSWP(YSN2)) Q:YSN2'>0 S YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)=YSWP(YSN2,0)
  1. ;
  1. I YSA'["{" S X=YSA D:$L(X) L Q ;DIWL=0,DIWR=IOM,X=YSA D ^DIWP Q
  1. PRO ;evaluate pronoun, possessive etc
  1. F YSZ=1:1:999 Q:YSA'["{" D
  1. . S P1=$F(YSA,"{")-1,P2=$F(YSA,"}")
  1. . Q:'P1!'P2
  1. . S G=$E(YSA,P1+1,P2-2),V=0
  1. . I $P(G,";")?."."1N.NP D D CONDIT,ULP
  1. .. S G2=$$GET1^DIQ(604,YSASDA_",",$P(G,";"),"","YSASWP")
  1. .. S V=$S(G2?1N.N:+G2,1:G2) ;5/30 ASF
  1. . S:G="Pro" V=$S(YSSEX="F":"She",1:"He")
  1. . S:G="pro" V=$S(YSSEX="F":"she",1:"he")
  1. . S:G="Pos" V=$S(YSSEX="F":"Her",1:"His")
  1. . S:G="pos" V=$S(YSSEX="F":"her",1:"his")
  1. . S:G="him" V=$S(YSSEX="F":"her",1:"him")
  1. . S:G="himself" V=$S(YSSEX="F":"herself",1:"himself")
  1. . S:G="Title" V=$S(YSSEX="F":"Ms.",1:"Mr.")
  1. . I G="Blank" S:$L($G(^TMP($J,"YSTMP",0,YSLFN,0))) YSLFN=YSLFN+1 S ^TMP($J,"YSTMP",0,YSLFN,0)=$G(^TMP($J,"YSTMP",0,YSLFN,0))_"|BLANK(1)||NOBLANKLINE|",YSLFN=YSLFN+1,V=""
  1. . S:G="Line" YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)="",V=""
  1. . I G="Last" S X=$P($P(^DPT(DFN,0),U),",") D
  1. .. 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)
  1. .. S V=X
  1. . I $P(G,";")="Field" S @($P(G,";",2))=$$GET1^DIQ(604,YSASDA_",",$P(G,";",3)),V="" I $P(G,";",4)'="" S YSSC=";",YSX="S @($P(G,YSSC,2))=$S("_$P(G,";",4)_")" X YSX
  1. . I $P(G,";")="List" K V D K V S V=""
  1. .. S V1=$P(G,";",2),I1=0 F I=1:1 Q:$P(V1,",",I)="" S:@($P(V1,",",I))'="" I1=I1+1,V(I1)=@($P(V1,",",I))
  1. .. I '$D(V(1)) S X=$P(G,";",3) D L Q
  1. .. F I1=1:1 Q:'$D(V(I1)) S X=$S(I1=1:" ",'$D(V(I1+1)):" and ",1:", ")_V(I1) D L
  1. R . ;called from YSASPNT
  1. . S X=$E(YSA,1,P1-1) D:$L(X) L
  1. . I $D(YSASWP) S V="" D K YSASWP
  1. .. F I3=1:1 Q:'$D(YSASWP(I3)) S X=YSASWP(I3)_" " D:$L(X) L
  1. . S X=V D:$L(X) L
  1. . S YSA=$E(YSA,P2,999)
  1. . I YSA'["{" S X=YSA D:$L(X) L
  1. ;
  1. Q
  1. SIG ; signature
  1. S YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)=""
  1. S YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)="esig: "
  1. S Y=$P($G(^YSTX(604,YSASDA,.5)),U,2) S:Y?1N.N Y=$G(^VA(200,Y,20)),Y=$P(Y,U,2)_" "_$P(Y,U,3)
  1. S ^TMP($J,"YSTMP",0,YSLFN,0)=^TMP($J,"YSTMP",0,YSLFN,0)_Y
  1. S Y=$G(^YSTX(604,YSASDA,12)) I Y'="" X ^DD("DD") S YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)="signed: "_Y
  1. Q
  1. END ;
  1. K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
  1. L ;
  1. S ^TMP($J,"YSTMP",0,YSLFN,0)=$G(^TMP($J,"YSTMP",0,YSLFN,0))_X
  1. I $L(^TMP($J,"YSTMP",0,YSLFN,0))>80 D
  1. . S Y=^TMP($J,"YSTMP",0,YSLFN,0)
  1. . F I=$L(Y):-1:1 S Y1=$E(Y,I) I Y1=" "&(I<81) S ^TMP($J,"YSTMP",0,YSLFN,0)=$E(Y,1,I-1),YSLFN=YSLFN+1,^TMP($J,"YSTMP",0,YSLFN,0)=$E(Y,I+1,999) Q
  1. Q
  1. PRT ; Print output
  1. W @IOF,YSHDR,! W:'YSASIG ?25,"##### Unsigned Draft #####",!
  1. S N=0 F S N=$O(^TMP($J,"YSTMP",0,N)) Q:N'>0!YSZZ D
  1. . S X=^TMP($J,"YSTMP",0,N,0),DIWL=1,DIWF="WN" D ^DIWP
  1. . I IOT'="HFS" D:$Y+4>IOSL WAIT ;ASF 3/7/03
  1. ;
  1. Q
  1. WAIT ;
  1. F I0=1:1:IOSL-$Y-2 W !
  1. N DTOUT,DUOUT,DIRUT
  1. I IOST?1"C".E W $C(7) K DIR S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT)
  1. Q:YSZZ
  1. W @IOF,YSHDR,! W:'YSASIG ?25,"##### Unsigned Draft #####",!
  1. Q
  1. TEST S G="X;;L",V="TEST"
  1. ULP ;
  1. Q:$P(G,";",3)=""
  1. Q:$P(G,";",3)="P"&($P(G,";")=".09:20.3") ;MJD 01/06/2000
  1. I $P(G,";",3)="P" F %=2:1:$L(V) I $E(V,%)?1U,$E(V,%-1)?1A S V=$E(V,0,%-1)_$C($A(V,%)+32)_$E(V,%+1,999)
  1. I $P(G,";",3)="L" F %=1:1:$L(V) I $E(V,%)?1U S V=$E(V,0,%-1)_$C($A(V,%)+32)_$E(V,%+1,999)
  1. I $P(G,";",3)="U" F %=1:1:$L(V) S:$E(V,%)?1L V=$E(V,0,%-1)_$C($A(V,%)-32)_$E(V,%+1,999)
  1. Q
  1. CONDIT ;conditional
  1. Q:$P(G,";",2)=""
  1. S YSX="S V=$S("_$P(G,";",2)_")"
  1. ;S X=YSX D ^DIM
  1. ;I '$D(X) S V="###ERROR Line "_YSJ_" ###" Q
  1. X YSX
  1. Q
  1. VARPRO ; PATIENT VARIABLES
  1. S YSPROU=$S(YSSEX="F":"She",1:"He")
  1. S YSPROL=$S(YSSEX="F":"she",1:"he")
  1. S YSPOSU=$S(YSSEX="F":"Her",1:"His")
  1. S YSPOSL=$S(YSSEX="F":"her",1:"his")
  1. S YSHIML=$S(YSSEX="F":"her",1:"him")
  1. S YSHIMU=$S(YSSEX="F":"Her",1:"Him")
  1. S YSTITLE=$S(YSSEX="F":"Ms.",1:"Mr.")
  1. S X=$P($P(^DPT(DFN,0),U),",") D S YSLAST=X
  1. . 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)
  1. Q