- 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 Mar 13, 2025@21:22:11 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
