YTFILE ;SLC/TGA-INSTRUMENT FILE MGMT. ;10/3/02 15:41
;;5.01;MENTAL HEALTH;**13,77**;Dec 30, 1994
;
L +^YTD(601.2,YSDFN):0 I '$D(^YTD(601.2,YSDFN,0)) L +^YTD(601.2,0):0 S ^YTD(601.2,YSDFN,0)=YSDFN,^YTD(601.2,"B",YSDFN,YSDFN)=""
I S X=^YTD(601.2,0),X(3)=$P(X,U,3),X(4)=$P(X,U,4) S X(4)=X(4)+1 S:YSDFN>X(3) X(3)=YSDFN S ^(0)=$P(X,U,1,2)_"^"_X(3)_"^"_X(4) L -^YTD(601.2,0)
S YSEN=YSTEST I $D(^YTD(601.2,YSDFN,1,YSEN)) G 11
I '$D(^YTD(601.2,YSDFN,1,0)) S ^(0)="^601.21PA^^"
S X=^YTD(601.2,YSDFN,1,0)
1 ;
S:YSEN>$P(X,U,3) $P(X,U,3)=YSEN S $P(X,U,4)=$P(X,U,4)+1,^YTD(601.2,YSDFN,1,0)=X,^YTD(601.2,YSDFN,1,YSEN,0)=YSTEST,^YTD(601.2,YSDFN,1,"B",YSEN,YSEN)=""
11 ;
I '$D(^YTD(601.2,YSDFN,1,YSEN,1,0)) S ^(0)="^601.22DA^^"
I '$D(^YTD(601.2,YSDFN,1,YSEN,1,DT,0)) S ^(0)=DT,X=^YTD(601.2,YSDFN,1,YSEN,1,0),$P(X,U,4)=$P(X,U,4)+1 S:DT>$P(X,U,3) $P(X,U,3)=DT S ^(0)=X
;
I $G(YSLC)="" D
. S YSLC=DUZ(2)
;
S X=DT_"^"_IO_"^"_YSORD_"^"_DUZ_"^"_$G(YSDTA)_"^"_$S($D(YSCLERK):1,1:2)_"^"_YSLC_"^"
S ^YTD(601.2,YSDFN,1,YSEN,1,DT,0)=X_$G(YSBEGIN)
S I=0 F S I=$O(^YTD(601.2,YSDFN,1,YSEN,1,DT,I)) Q:'I K ^(I)
I $D(YSCLERK) S YSTEST=YSCLERK
K YSENT I $D(^YTD(601.4,YSDFN,1,YSTEST)) S YSENT=YSTEST,K=0 F S K=$O(^YTD(601.4,YSDFN,1,YSENT,K)) Q:'K S ^YTD(601.2,YSDFN,1,YSEN,1,DT,K)=^YTD(601.4,YSDFN,1,YSENT,K)
S:YSRP'="" ^YTD(601.2,YSDFN,1,YSEN,1,DT,J+199\200)=YSRP
S DIK="^YTD(601.2,",DA=YSDFN,DA(1)=YSEN,DA(2)=DT D IX^DIK K DIK ;ASF 10/02/02
S YSTEST(1)=$S($D(YSCLERK):1,1:2) I YSTEST(1)=1 S YSTEST=YSCL
I $P(^YTT(601,YSTEST,0),U,9)="T" S X=$E(DT,1,5) S:$D(^YTD(601.2,"AD",YSLC,YSTEST(1),X,YSTEST)) ^(YSTEST)=^(YSTEST)+1 S:'$D(^(YSTEST)) ^(YSTEST)=1
L D:$D(YSENT) ENKIL Q:'$D(YSCLERK) Q:'$D(^YTT(601,YSTEST,"T")) Q:^("T")']"" D XF Q
ENKIL ;
L +^YTD(601.4,YSDFN):0 K ^YTD(601.4,YSDFN,1,YSENT) I '$D(YSCLERK) K ^YTD(601.4,YSDFN,1,"B",YSTEST)
E K ^YTD(601.4,YSDFN,1,"AC",YSCL),^YTD(601.4,YSDFN,1,"B",YSCLERK)
I $D(^YTD(601.4,YSDFN,1,0)) S X=$P(^(0),U,4),X=X-1 S:X<0 X=0 S $P(^(0),U,4)=X
I '$O(^YTD(601.4,YSDFN,1,0)) D
.K ^YTD(601.4,YSDFN),^YTD(601.4,"B",YSDFN) L +^YTD(601.4,0):0 S X=^YTD(601.4,0),X4=$P(X,U,4),X3=$P(X,U,3),X4=X4-1 S:X4<0 X4=0 S:'$O(^YTD(601.4,0)) X3="" S ^YTD(601.4,0)=$P(X,U,1,2)_"^"_X3_"^"_X4
.L -^YTD(601.4,0)
L -^YTD(601.4,YSDFN)
Q
;
EN4 ;
L:YS4D +^YTD(601.4,YSDFN):0 D EN40:'YS4D,42 L -^YTD(601.4,YSDFN) Q
EN40 ;
S YS4D=1 L +^YTD(601.4,YSDFN):0 I '$D(^YTD(601.4,YSDFN,0)) L +^YTD(601.4,0):0 S X=^YTD(601.4,0),X(4)=$P(X,U,4),X(3)=$P(X,U,3),X(4)=X(4)+1 S:YSDFN>X(3) X(3)=YSDFN S X=$P(X,U,1,2)_"^"_X(3)_"^"_X(4) L -^YTD(601.4,0)
I S ^YTD(601.4,0)=X,^YTD(601.4,YSDFN,0)=YSDFN,^YTD(601.4,"B",YSDFN,YSDFN)=""
I '$D(^YTD(601.4,YSDFN,1,0)) S ^YTD(601.4,YSDFN,1,0)="^601.41P^^"
L -^YTD(601.4,YSDFN) S YSENT=$S($D(YSCLERK):YSCLERK,1:YSTEST) I $D(^YTD(601.4,YSDFN,1,YSENT)) Q
S X=^YTD(601.4,YSDFN,1,0) S:YSENT>$P(X,U,3) $P(X,U,3)=YSENT S $P(X,U,4)=$P(X,U,4)+1,^YTD(601.4,YSDFN,1,0)=X Q
42 ;
S ^YTD(601.4,YSDFN,1,YSENT,0)=YSENT_"^"_YSHD_"^^"_(J+1)_"^"_$G(C),^YTD(601.4,YSDFN,1,"B",YSENT,YSENT)=""
I $D(B) S ^YTD(601.4,YSDFN,1,YSENT,"B")=B
S ^YTD(601.4,YSDFN,1,YSENT,J\200)=YSRP,YSRP="" Q
XF ;
K X S I=0 F S I=$O(^YTD(601.2,YSDFN,1,YSEN,1,DT,I)) Q:'I S X(I)=^(I)
X:$D(^YTT(601,YSTEST,"T")) ^YTT(601,YSTEST,"T") F I=0:0 S I=$O(X(I)) Q:'I S ^YTD(601.2,YSDFN,1,YSEN,1,DT,I)=X(I)
;
K YS4D,YSBEGIN,YSCL,YSCLERK,YSDTA,YSEN,YSHD,YSLC,YSORD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTFILE 3424 printed Nov 22, 2024@17:27:21 Page 2
YTFILE ;SLC/TGA-INSTRUMENT FILE MGMT. ;10/3/02 15:41
+1 ;;5.01;MENTAL HEALTH;**13,77**;Dec 30, 1994
+2 ;
+3 LOCK +^YTD(601.2,YSDFN):0
IF '$DATA(^YTD(601.2,YSDFN,0))
LOCK +^YTD(601.2,0):0
SET ^YTD(601.2,YSDFN,0)=YSDFN
SET ^YTD(601.2,"B",YSDFN,YSDFN)=""
+4 IF $TEST
SET X=^YTD(601.2,0)
SET X(3)=$PIECE(X,U,3)
SET X(4)=$PIECE(X,U,4)
SET X(4)=X(4)+1
if YSDFN>X(3)
SET X(3)=YSDFN
SET ^(0)=$PIECE(X,U,1,2)_"^"_X(3)_"^"_X(4)
LOCK -^YTD(601.2,0)
+5 SET YSEN=YSTEST
IF $DATA(^YTD(601.2,YSDFN,1,YSEN))
GOTO 11
+6 IF '$DATA(^YTD(601.2,YSDFN,1,0))
SET ^(0)="^601.21PA^^"
+7 SET X=^YTD(601.2,YSDFN,1,0)
1 ;
+1 if YSEN>$PIECE(X,U,3)
SET $PIECE(X,U,3)=YSEN
SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
SET ^YTD(601.2,YSDFN,1,0)=X
SET ^YTD(601.2,YSDFN,1,YSEN,0)=YSTEST
SET ^YTD(601.2,YSDFN,1,"B",YSEN,YSEN)=""
11 ;
+1 IF '$DATA(^YTD(601.2,YSDFN,1,YSEN,1,0))
SET ^(0)="^601.22DA^^"
+2 IF '$DATA(^YTD(601.2,YSDFN,1,YSEN,1,DT,0))
SET ^(0)=DT
SET X=^YTD(601.2,YSDFN,1,YSEN,1,0)
SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
if DT>$PIECE(X,U,3)
SET $PIECE(X,U,3)=DT
SET ^(0)=X
+3 ;
+4 IF $GET(YSLC)=""
Begin DoDot:1
+5 SET YSLC=DUZ(2)
End DoDot:1
+6 ;
+7 SET X=DT_"^"_IO_"^"_YSORD_"^"_DUZ_"^"_$GET(YSDTA)_"^"_$SELECT($DATA(YSCLERK):1,1:2)_"^"_YSLC_"^"
+8 SET ^YTD(601.2,YSDFN,1,YSEN,1,DT,0)=X_$GET(YSBEGIN)
+9 SET I=0
FOR
SET I=$ORDER(^YTD(601.2,YSDFN,1,YSEN,1,DT,I))
if 'I
QUIT
KILL ^(I)
+10 IF $DATA(YSCLERK)
SET YSTEST=YSCLERK
+11 KILL YSENT
IF $DATA(^YTD(601.4,YSDFN,1,YSTEST))
SET YSENT=YSTEST
SET K=0
FOR
SET K=$ORDER(^YTD(601.4,YSDFN,1,YSENT,K))
if 'K
QUIT
SET ^YTD(601.2,YSDFN,1,YSEN,1,DT,K)=^YTD(601.4,YSDFN,1,YSENT,K)
+12 if YSRP'=""
SET ^YTD(601.2,YSDFN,1,YSEN,1,DT,J+199\200)=YSRP
+13 ;ASF 10/02/02
SET DIK="^YTD(601.2,"
SET DA=YSDFN
SET DA(1)=YSEN
SET DA(2)=DT
DO IX^DIK
KILL DIK
+14 SET YSTEST(1)=$SELECT($DATA(YSCLERK):1,1:2)
IF YSTEST(1)=1
SET YSTEST=YSCL
+15 IF $PIECE(^YTT(601,YSTEST,0),U,9)="T"
SET X=$EXTRACT(DT,1,5)
if $DATA(^YTD(601.2,"AD",YSLC,YSTEST(1),X,YSTEST))
SET ^(YSTEST)=^(YSTEST)+1
if '$DATA(^(YSTEST))
SET ^(YSTEST)=1
+16 LOCK
if $DATA(YSENT)
DO ENKIL
if '$DATA(YSCLERK)
QUIT
if '$DATA(^YTT(601,YSTEST,"T"))
QUIT
if ^("T")']""
QUIT
DO XF
QUIT
ENKIL ;
+1 LOCK +^YTD(601.4,YSDFN):0
KILL ^YTD(601.4,YSDFN,1,YSENT)
IF '$DATA(YSCLERK)
KILL ^YTD(601.4,YSDFN,1,"B",YSTEST)
+2 IF '$TEST
KILL ^YTD(601.4,YSDFN,1,"AC",YSCL),^YTD(601.4,YSDFN,1,"B",YSCLERK)
+3 IF $DATA(^YTD(601.4,YSDFN,1,0))
SET X=$PIECE(^(0),U,4)
SET X=X-1
if X<0
SET X=0
SET $PIECE(^(0),U,4)=X
+4 IF '$ORDER(^YTD(601.4,YSDFN,1,0))
Begin DoDot:1
+5 KILL ^YTD(601.4,YSDFN),^YTD(601.4,"B",YSDFN)
LOCK +^YTD(601.4,0):0
SET X=^YTD(601.4,0)
SET X4=$PIECE(X,U,4)
SET X3=$PIECE(X,U,3)
SET X4=X4-1
if X4<0
SET X4=0
if '$ORDER(^YTD(601.4,0))
SET X3=""
SET ^YTD(601.4,0)=$PIECE(X,U,1,2)_"^"_X3_"^"_X4
+6 LOCK -^YTD(601.4,0)
End DoDot:1
+7 LOCK -^YTD(601.4,YSDFN)
+8 QUIT
+9 ;
EN4 ;
+1 if YS4D
LOCK +^YTD(601.4,YSDFN):0
if 'YS4D
DO EN40
DO 42
LOCK -^YTD(601.4,YSDFN)
QUIT
EN40 ;
+1 SET YS4D=1
LOCK +^YTD(601.4,YSDFN):0
IF '$DATA(^YTD(601.4,YSDFN,0))
LOCK +^YTD(601.4,0):0
SET X=^YTD(601.4,0)
SET X(4)=$PIECE(X,U,4)
SET X(3)=$PIECE(X,U,3)
SET X(4)=X(4)+1
if YSDFN>X(3)
SET X(3)=YSDFN
SET X=$PIECE(X,U,1,2)_"^"_X(3)_"^"_X(4)
LOCK -^YTD(601.4,0)
+2 IF $TEST
SET ^YTD(601.4,0)=X
SET ^YTD(601.4,YSDFN,0)=YSDFN
SET ^YTD(601.4,"B",YSDFN,YSDFN)=""
+3 IF '$DATA(^YTD(601.4,YSDFN,1,0))
SET ^YTD(601.4,YSDFN,1,0)="^601.41P^^"
+4 LOCK -^YTD(601.4,YSDFN)
SET YSENT=$SELECT($DATA(YSCLERK):YSCLERK,1:YSTEST)
IF $DATA(^YTD(601.4,YSDFN,1,YSENT))
QUIT
+5 SET X=^YTD(601.4,YSDFN,1,0)
if YSENT>$PIECE(X,U,3)
SET $PIECE(X,U,3)=YSENT
SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
SET ^YTD(601.4,YSDFN,1,0)=X
QUIT
42 ;
+1 SET ^YTD(601.4,YSDFN,1,YSENT,0)=YSENT_"^"_YSHD_"^^"_(J+1)_"^"_$GET(C)
SET ^YTD(601.4,YSDFN,1,"B",YSENT,YSENT)=""
+2 IF $DATA(B)
SET ^YTD(601.4,YSDFN,1,YSENT,"B")=B
+3 SET ^YTD(601.4,YSDFN,1,YSENT,J\200)=YSRP
SET YSRP=""
QUIT
XF ;
+1 KILL X
SET I=0
FOR
SET I=$ORDER(^YTD(601.2,YSDFN,1,YSEN,1,DT,I))
if 'I
QUIT
SET X(I)=^(I)
+2 if $DATA(^YTT(601,YSTEST,"T"))
XECUTE ^YTT(601,YSTEST,"T")
FOR I=0:0
SET I=$ORDER(X(I))
if 'I
QUIT
SET ^YTD(601.2,YSDFN,1,YSEN,1,DT,I)=X(I)
+3 ;
+4 KILL YS4D,YSBEGIN,YSCL,YSCLERK,YSDTA,YSEN,YSHD,YSLC,YSORD
