YTEXT ;SLC/TGA-TEXT I/O FOR STAFF REMARKS ; 7/6/89 13:55 ;03/11/94 14:26
;;5.01;MENTAL HEALTH;**37,187**;Dec 30, 1994;Build 73
;
; Called from the top by MENU option YSCOMMENT
;
W @IOF,!!,"Staff Comments - Tests and Interviews"
I '$D(YSDT(0)) K Y D ENDD^YSUTL
1 ;
W ! D ^YSLRP I YSDFN'>0 D END Q
2 ;
K A,A1 ; 3/11/94 LJA - Clear variable "leftovers"...
D NX1^YTS I YSNT<1 W !!,"No completed instruments found" G 1
W !!?10,"--- Previous Instruments ---",! S B=$S(YSNT<11:YSNT,1:YSNT+1\2)
3 ;
F K=1:1:B S YSDT=$P(A1(K),U,2) W !?10,K,?15,$P(A1(K),U),?22,$$DAT(YSDT) I B'=YSNT,$D(A1(B+K)) W ?45,B+K,?50,$P(A1(B+K),U) S YSDT=$P(A1(B+K),U,2) W ?57,$$DAT(YSDT)
I ;
S DIR(0)="NO^1:"_YSNT_":0",DIR("A")="Select Instrument Number"
W !! D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT)
G 1:YSUOUT!'Y,END:YSTOUT S YSTEST=Y
I '$D(A1(YSTEST)) W:YSTEST'["?" " ?",$C(7) G I
S X=$P(A1(YSTEST),U,3) I '$D(^XUSEC("YSP",DUZ)),$P(^YTT(601,X,0),U,9)="T",$P(^(0),U,10)'="Y" S YSEC=1 G LU ;DISPLAY SECURITY CK
D ;
R !!,"Shall I display the results now? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G END:YSTOUT S A=$TR($E(A_"N"),"yn","YN") G 3:YSUOUT,LU:"N"[A,DR:"Y"[A W:A'["?" $C(7)," ?" W !,"Answer 'Yes' or 'No'" G D
DR ;
S YSXT=$P(A1(YSTEST),U,2)_","_$P(A1(YSTEST),U,3),YSHDR="xxx-xx-"_$E(YSSSN,$L(YSSSN)-3,$L(YSSSN))_" "_YSNM,YSSX=YSSEX,^UTILITY($J)=YSDFN_U_A1(YSTEST) F I=1:1:43 Q:$L(YSHDR)>42 S YSHDR=YSHDR_" "
;D RP^YTDP G:YSTXTED!POP END S X=^UTILITY($J),YSDFN=$P(X,U),YSTEST=$P(X,U,4),A1(YSTEST)=$P(X,U,2,4) D ENPT^YSUTL
D RP^YTDP G:YSTOUT!POP END S X=^UTILITY($J),YSDFN=$P(X,U),YSTEST=$P(X,U,4),A1(YSTEST)=$P(X,U,2,4) D ENPT^YSUTL
LU ;
S (YSP1,YSP2)=0,YSET=$P(A1(YSTEST),U,3),YSED=$P(A1(YSTEST),U,2),YSLFT=0
I $G(YSEC) D E G:YSLFT END G 2
S I=0 F S I=$O(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",I)) Q:'I S X=^(I,0) D LU1
I YSP1<1,YSP2<1 D E G:YSLFT END G LU
A ;
S X="Ee"_$S(YSP1:"Pp",1:"")_$S(YSP2:"Ss",1:"")
W !!,"(E)nter" W:YSP1 " or (P)rint" W:YSP2 " or (S)ign" W " comments: " R A:DTIME S YSTOUT='$T,YSUOUT=A["^" I YSTOUT G END
I YSUOUT!(A']"") G 2
S A=$E(A) I X'[A W:A'["?" " ?",$C(7) W !!,"Type 'E'" W:YSP1 " or 'P'" W:YSP2 " or 'S'" G A
S:"Pp"[A A="^YTEXT1" S:"Ee"[A A="E" D @A G:YSLFT END G LU
E ;
N A,A1
S:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",0)) ^(0)="^601.2213D^^" S DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"",",DIC(0)="L",DLAYGO=601,X="T" D ^DIC G:Y<1 OUT S YSDN=+Y
S DIE=DIC,DA=+Y,DR="1//TODAY;2///`"_DUZ_";3;9",DA(3)=YSDFN,DA(2)=YSET,DA(1)=YSED L +^YTD(601.2,YSDFN):DILOCKTM D ^DIE L -^YTD(601.2,YSDFN) S YSTOUT=$D(DTOUT)
E0 ;
S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSDN,0) F I=2:1:4 I '$P(X,U,I) D DEL Q
Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSDN)) I '$D(^(YSDN,1,1,0)) D DEL Q
E1 ;
; commented out lines represent electronic signature on
; comments added to MH insturments the file structure is present to
; support this but the EP does not want it in place at this time 5.0, 1992
;W !!,"Comment will be sealed upon signing."
R !,"Do you wish to review comment prior to filing? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G OUT:YSTOUT!YSUOUT S A=$E(A) G E2:"Nn"[A I "Yy"'[A W:A'["?" " ?",$C(7) G E1
S DR=9 L +^YTD(601.2,YSDFN):DILOCKTM D ^DIE L -^YTD(601.2,YSDFN) G E0
E2 ;
;R !!,"Do you wish to afix your signature to this comment? Y// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G OUT:YSTOUT!YSUOUT S A=$TR($E(A_"Y"),"yn","YN") G E3:"N"[A I "Y"'[A W:A'["?" " ?" G E2
;S DR="4///^S X=1";5///NOW" L +^YTD(601.2,YSDFN) D ^DIE L -^YTD(601.2,YSDFN) Q:$D(DTOUT)
E3 ;
R !!,"File this comment now? Y// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" I YSTOUT!YSUOUT D DEL G OUT
S A=$TR($E(A_"Y"),"yn","YN") I "N"[A D DEL G OUT
I "Y"'[A W:A'["?" " ?",$C(7) G E3
W !!,"Comment filed" Q
OUT ;
S YSLFT=1 Q
END ;
K %,%DT,%ZIS,%Y,A,A1,B,D,D0,DA,DIC,DIE,DIK,DIW,DIWF,DIWL,DIWR,DIWT,DN,DO,DQ,DR,DW2,DWI,I,J,K,N,N1,N2,N4,T2,X,X9,Y,YSAGE,YSCON,YSD,YSDFN,YSDN,YSDOB,YSED,YSES,YSET,YSFHDR,YSFTR,YSHDR,YSHDT
K YSI,YSJ,YSLFT,YSN,YSNM,YSNT,YSP0,YSP1,YSP2,YSPF,YSEC,YSSEX,YSSSN,YSTEST,YSTF,YSTX,YSTXTED,YSU,Z,ZTSK,^UTILITY($J) Q
LU1 ;
I DUZ=$P(X,U,4) S YSP1=1 S:'$P(X,U,5) YSP2=1
E S:$P(X,U,5) YSP1=1
S YSP1=1 ;ENABLE PRINT WITHOUT ELECTRONIC SIGNATURE
S YSP2=0 ;DISABLE ELECTRONIC SIGNATURE
Q
DAT(X) ;
S X=$$FMTE^XLFDT(X,"5ZD") Q X
CK ;
S:YSP0 YSCON=1 D ENFT^YSFORM:YSP0,WAIT^YSUTL:'YSP0 Q:YSLFT D:YSP0 ENHD^YSFORM Q
DEL ;
S DA=YSDN,DIK=DIC D ^DIK W !!,"No comment filed" S YSLFT=1 Q
S ;
S DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"",",DIC(0)="AEQ",DIC("S")="I DUZ=$P(^(0),U,4),$P(^(0),U,5)=""""" D ^DIC K DIC("S") Q:Y'>0 S DA=+Y,YSDN=+Y D E1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTEXT 4639 printed Dec 13, 2024@02:17:17 Page 2
YTEXT ;SLC/TGA-TEXT I/O FOR STAFF REMARKS ; 7/6/89 13:55 ;03/11/94 14:26
+1 ;;5.01;MENTAL HEALTH;**37,187**;Dec 30, 1994;Build 73
+2 ;
+3 ; Called from the top by MENU option YSCOMMENT
+4 ;
+5 WRITE @IOF,!!,"Staff Comments - Tests and Interviews"
+6 IF '$DATA(YSDT(0))
KILL Y
DO ENDD^YSUTL
1 ;
+1 WRITE !
DO ^YSLRP
IF YSDFN'>0
DO END
QUIT
2 ;
+1 ; 3/11/94 LJA - Clear variable "leftovers"...
KILL A,A1
+2 DO NX1^YTS
IF YSNT<1
WRITE !!,"No completed instruments found"
GOTO 1
+3 WRITE !!?10,"--- Previous Instruments ---",!
SET B=$SELECT(YSNT<11:YSNT,1:YSNT+1\2)
3 ;
+1 FOR K=1:1:B
SET YSDT=$PIECE(A1(K),U,2)
WRITE !?10,K,?15,$PIECE(A1(K),U),?22,$$DAT(YSDT)
IF B'=YSNT
IF $DATA(A1(B+K))
WRITE ?45,B+K,?50,$PIECE(A1(B+K),U)
SET YSDT=$PIECE(A1(B+K),U,2)
WRITE ?57,$$DAT(YSDT)
I ;
+1 SET DIR(0)="NO^1:"_YSNT_":0"
SET DIR("A")="Select Instrument Number"
+2 WRITE !!
DO ^DIR
KILL DIR
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
+3 if YSUOUT!'Y
GOTO 1
if YSTOUT
GOTO END
SET YSTEST=Y
+4 IF '$DATA(A1(YSTEST))
if YSTEST'["?"
WRITE " ?",$CHAR(7)
GOTO I
+5 ;DISPLAY SECURITY CK
SET X=$PIECE(A1(YSTEST),U,3)
IF '$DATA(^XUSEC("YSP",DUZ))
IF $PIECE(^YTT(601,X,0),U,9)="T"
IF $PIECE(^(0),U,10)'="Y"
SET YSEC=1
GOTO LU
D ;
+1 READ !!,"Shall I display the results now? N// ",A:DTIME
SET YSTOUT='$TEST
SET YSUOUT=A["^"
if YSTOUT
GOTO END
SET A=$TRANSLATE($EXTRACT(A_"N"),"yn","YN")
if YSUOUT
GOTO 3
if "N"[A
GOTO LU
if "Y"[A
GOTO DR
if A'["?"
WRITE $CHAR(7)," ?"
WRITE !,"Answer 'Yes' or 'No'"
GOTO D
DR ;
+1 SET YSXT=$PIECE(A1(YSTEST),U,2)_","_$PIECE(A1(YSTEST),U,3)
SET YSHDR="xxx-xx-"_$EXTRACT(YSSSN,$LENGTH(YSSSN)-3,$LENGTH(YSSSN))_" "_YSNM
SET YSSX=YSSEX
SET ^UTILITY($JOB)=YSDFN_U_A1(YSTEST)
FOR I=1:1:43
if $LENGTH(YSHDR)>42
QUIT
SET YSHDR=YSHDR_" "
+2 ;D RP^YTDP G:YSTXTED!POP END S X=^UTILITY($J),YSDFN=$P(X,U),YSTEST=$P(X,U,4),A1(YSTEST)=$P(X,U,2,4) D ENPT^YSUTL
+3 DO RP^YTDP
if YSTOUT!POP
GOTO END
SET X=^UTILITY($JOB)
SET YSDFN=$PIECE(X,U)
SET YSTEST=$PIECE(X,U,4)
SET A1(YSTEST)=$PIECE(X,U,2,4)
DO ENPT^YSUTL
LU ;
+1 SET (YSP1,YSP2)=0
SET YSET=$PIECE(A1(YSTEST),U,3)
SET YSED=$PIECE(A1(YSTEST),U,2)
SET YSLFT=0
+2 IF $GET(YSEC)
DO E
if YSLFT
GOTO END
GOTO 2
+3 SET I=0
FOR
SET I=$ORDER(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",I))
if 'I
QUIT
SET X=^(I,0)
DO LU1
+4 IF YSP1<1
IF YSP2<1
DO E
if YSLFT
GOTO END
GOTO LU
A ;
+1 SET X="Ee"_$SELECT(YSP1:"Pp",1:"")_$SELECT(YSP2:"Ss",1:"")
+2 WRITE !!,"(E)nter"
if YSP1
WRITE " or (P)rint"
if YSP2
WRITE " or (S)ign"
WRITE " comments: "
READ A:DTIME
SET YSTOUT='$TEST
SET YSUOUT=A["^"
IF YSTOUT
GOTO END
+3 IF YSUOUT!(A']"")
GOTO 2
+4 SET A=$EXTRACT(A)
IF X'[A
if A'["?"
WRITE " ?",$CHAR(7)
WRITE !!,"Type 'E'"
if YSP1
WRITE " or 'P'"
if YSP2
WRITE " or 'S'"
GOTO A
+5 if "Pp"[A
SET A="^YTEXT1"
if "Ee"[A
SET A="E"
DO @A
if YSLFT
GOTO END
GOTO LU
E ;
+1 NEW A,A1
+2 if '$DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",0))
SET ^(0)="^601.2213D^^"
SET DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"","
SET DIC(0)="L"
SET DLAYGO=601
SET X="T"
DO ^DIC
if Y<1
GOTO OUT
SET YSDN=+Y
+3 SET DIE=DIC
SET DA=+Y
SET DR="1//TODAY;2///`"_DUZ_";3;9"
SET DA(3)=YSDFN
SET DA(2)=YSET
SET DA(1)=YSED
LOCK +^YTD(601.2,YSDFN):DILOCKTM
DO ^DIE
LOCK -^YTD(601.2,YSDFN)
SET YSTOUT=$DATA(DTOUT)
E0 ;
+1 SET X=^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSDN,0)
FOR I=2:1:4
IF '$PIECE(X,U,I)
DO DEL
QUIT
+2 if '$DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED,"R",YSDN))
QUIT
IF '$DATA(^(YSDN,1,1,0))
DO DEL
QUIT
E1 ;
+1 ; commented out lines represent electronic signature on
+2 ; comments added to MH insturments the file structure is present to
+3 ; support this but the EP does not want it in place at this time 5.0, 1992
+4 ;W !!,"Comment will be sealed upon signing."
+5 READ !,"Do you wish to review comment prior to filing? N// ",A:DTIME
SET YSTOUT='$TEST
SET YSUOUT=A["^"
if YSTOUT!YSUOUT
GOTO OUT
SET A=$EXTRACT(A)
if "Nn"[A
GOTO E2
IF "Yy"'[A
if A'["?"
WRITE " ?",$CHAR(7)
GOTO E1
+6 SET DR=9
LOCK +^YTD(601.2,YSDFN):DILOCKTM
DO ^DIE
LOCK -^YTD(601.2,YSDFN)
GOTO E0
E2 ;
+1 ;R !!,"Do you wish to afix your signature to this comment? Y// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G OUT:YSTOUT!YSUOUT S A=$TR($E(A_"Y"),"yn","YN") G E3:"N"[A I "Y"'[A W:A'["?" " ?" G E2
+2 ;S DR="4///^S X=1";5///NOW" L +^YTD(601.2,YSDFN) D ^DIE L -^YTD(601.2,YSDFN) Q:$D(DTOUT)
E3 ;
+1 READ !!,"File this comment now? Y// ",A:DTIME
SET YSTOUT='$TEST
SET YSUOUT=A["^"
IF YSTOUT!YSUOUT
DO DEL
GOTO OUT
+2 SET A=$TRANSLATE($EXTRACT(A_"Y"),"yn","YN")
IF "N"[A
DO DEL
GOTO OUT
+3 IF "Y"'[A
if A'["?"
WRITE " ?",$CHAR(7)
GOTO E3
+4 WRITE !!,"Comment filed"
QUIT
OUT ;
+1 SET YSLFT=1
QUIT
END ;
+1 KILL %,%DT,%ZIS,%Y,A,A1,B,D,D0,DA,DIC,DIE,DIK,DIW,DIWF,DIWL,DIWR,DIWT,DN,DO,DQ,DR,DW2,DWI,I,J,K,N,N1,N2,N4,T2,X,X9,Y,YSAGE,YSCON,YSD,YSDFN,YSDN,YSDOB,YSED,YSES,YSET,YSFHDR,YSFTR,YSHDR,YSHDT
+2 KILL YSI,YSJ,YSLFT,YSN,YSNM,YSNT,YSP0,YSP1,YSP2,YSPF,YSEC,YSSEX,YSSSN,YSTEST,YSTF,YSTX,YSTXTED,YSU,Z,ZTSK,^UTILITY($JOB)
QUIT
LU1 ;
+1 IF DUZ=$PIECE(X,U,4)
SET YSP1=1
if '$PIECE(X,U,5)
SET YSP2=1
+2 IF '$TEST
if $PIECE(X,U,5)
SET YSP1=1
+3 ;ENABLE PRINT WITHOUT ELECTRONIC SIGNATURE
SET YSP1=1
+4 ;DISABLE ELECTRONIC SIGNATURE
SET YSP2=0
+5 QUIT
DAT(X) ;
+1 SET X=$$FMTE^XLFDT(X,"5ZD")
QUIT X
CK ;
+1 if YSP0
SET YSCON=1
if YSP0
DO ENFT^YSFORM
if 'YSP0
DO WAIT^YSUTL
if YSLFT
QUIT
if YSP0
DO ENHD^YSFORM
QUIT
DEL ;
+1 SET DA=YSDN
SET DIK=DIC
DO ^DIK
WRITE !!,"No comment filed"
SET YSLFT=1
QUIT
S ;
+1 SET DIC="^YTD(601.2,YSDFN,1,YSET,1,YSED,""R"","
SET DIC(0)="AEQ"
SET DIC("S")="I DUZ=$P(^(0),U,4),$P(^(0),U,5)="""""
DO ^DIC
KILL DIC("S")
if Y'>0
QUIT
SET DA=+Y
SET YSDN=+Y
DO E1
