source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTFILE.m@ 648

Last change on this file since 648 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1YTFILE ;SLC/TGA-INSTRUMENT FILE MGMT. ;10/3/02 15:41
2 ;;5.01;MENTAL HEALTH;**13,77**;Dec 30, 1994
3 ;
4 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)=""
5 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)
6 S YSEN=YSTEST I $D(^YTD(601.2,YSDFN,1,YSEN)) G 11
7 I '$D(^YTD(601.2,YSDFN,1,0)) S ^(0)="^601.21PA^^"
8 S X=^YTD(601.2,YSDFN,1,0)
91 ;
10 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)=""
1111 ;
12 I '$D(^YTD(601.2,YSDFN,1,YSEN,1,0)) S ^(0)="^601.22DA^^"
13 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
14 ;
15 I $G(YSLC)="" D
16 . S YSLC=DUZ(2)
17 ;
18 S X=DT_"^"_IO_"^"_YSORD_"^"_DUZ_"^"_$G(YSDTA)_"^"_$S($D(YSCLERK):1,1:2)_"^"_YSLC_"^"
19 S ^YTD(601.2,YSDFN,1,YSEN,1,DT,0)=X_$G(YSBEGIN)
20 S I=0 F S I=$O(^YTD(601.2,YSDFN,1,YSEN,1,DT,I)) Q:'I K ^(I)
21 I $D(YSCLERK) S YSTEST=YSCLERK
22 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)
23 S:YSRP'="" ^YTD(601.2,YSDFN,1,YSEN,1,DT,J+199\200)=YSRP
24 S DIK="^YTD(601.2,",DA=YSDFN,DA(1)=YSEN,DA(2)=DT D IX^DIK K DIK ;ASF 10/02/02
25 S YSTEST(1)=$S($D(YSCLERK):1,1:2) I YSTEST(1)=1 S YSTEST=YSCL
26 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
27 L D:$D(YSENT) ENKIL Q:'$D(YSCLERK) Q:'$D(^YTT(601,YSTEST,"T")) Q:^("T")']"" D XF Q
28ENKIL ;
29 L +^YTD(601.4,YSDFN):0 K ^YTD(601.4,YSDFN,1,YSENT) I '$D(YSCLERK) K ^YTD(601.4,YSDFN,1,"B",YSTEST)
30 E K ^YTD(601.4,YSDFN,1,"AC",YSCL),^YTD(601.4,YSDFN,1,"B",YSCLERK)
31 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
32 I '$O(^YTD(601.4,YSDFN,1,0)) D
33 .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
34 .L -^YTD(601.4,0)
35 L -^YTD(601.4,YSDFN)
36 Q
37 ;
38EN4 ;
39 L:YS4D +^YTD(601.4,YSDFN):0 D EN40:'YS4D,42 L -^YTD(601.4,YSDFN) Q
40EN40 ;
41 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)
42 I S ^YTD(601.4,0)=X,^YTD(601.4,YSDFN,0)=YSDFN,^YTD(601.4,"B",YSDFN,YSDFN)=""
43 I '$D(^YTD(601.4,YSDFN,1,0)) S ^YTD(601.4,YSDFN,1,0)="^601.41P^^"
44 L -^YTD(601.4,YSDFN) S YSENT=$S($D(YSCLERK):YSCLERK,1:YSTEST) I $D(^YTD(601.4,YSDFN,1,YSENT)) Q
45 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
4642 ;
47 S ^YTD(601.4,YSDFN,1,YSENT,0)=YSENT_"^"_YSHD_"^^"_(J+1)_"^"_$G(C),^YTD(601.4,YSDFN,1,"B",YSENT,YSENT)=""
48 I $D(B) S ^YTD(601.4,YSDFN,1,YSENT,"B")=B
49 S ^YTD(601.4,YSDFN,1,YSENT,J\200)=YSRP,YSRP="" Q
50XF ;
51 K X S I=0 F S I=$O(^YTD(601.2,YSDFN,1,YSEN,1,DT,I)) Q:'I S X(I)=^(I)
52 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)
53 ;
54 K YS4D,YSBEGIN,YSCL,YSCLERK,YSDTA,YSEN,YSHD,YSLC,YSORD
Note: See TracBrowser for help on using the repository browser.