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