source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSKFASI2.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1YSKFASI2 ;16IT/PTC - SUBSTANCE ABUSE ;9/4/01 13:40
2 ;;5.01;MENTAL HEALTH;**73**;Dec 30, 1994
3 ;
4 ;Reference to ^DGPT( supported by IA #564
5 ;Reference to ^SCE( supported by IA #402
6 ;Reference to ^SCE("ADFN" supported by IA #402
7 ;Reference to ^SCE("B" supported by IA #402
8 D NEW,ASI
9 Q
10NEW ;decide if new patient
11 S YSKFDFN=0 F S YSKFDFN=$O(^TMP("XNNEW",$J,YSKFDFN)) Q:YSKFDFN'>0 S STOP=0,YSKFDT=$O(^TMP("XNNEW",$J,YSKFDFN,0)) Q:YSKFDT'>0 D
12 .I '$D(^TMP("24STAY",$J,YSKFDFN))&('$D(^UTILITY($J,"TRDOP",YSKFDFN))) Q ; not eligible to consider
13 .S X1=YSKFDT,X2=-90 D C^%DTC S YSKF90=(X-.001) S ^TMP("CHKDT",$J,YSKFDFN)=+^TMP("XNNEW",$J,YSKFDFN,YSKFDT)_U_YSKFDT_U_YSKF90
14 .I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=1 S (NXTDT,NXTDT2)=YSKFDT F S NXTDT=$O(^TMP("XNNEW",$J,YSKFDFN,NXTDT)) Q:NXTDT'>0!(STOP=1) S X1=NXTDT,X2=NXTDT2 D ^%DTC D
15 ..I X<91 K ^TMP("CHKDT",$J,YSKFDFN) S X1=NXTDT2,X2=-90 D C^%DTC S YSKF90=(X-.001) S STOP=1,^TMP("CHKDT",$J,YSKFDFN)=1_U_NXTDT2_U_YSKF90 Q ;PC 8/3/01
16 ..I X>90 D
17 ...I +^TMP("XNNEW",$J,YSKFDFN,NXTDT)=1 S NXTDT2=NXTDT Q
18 ...I +^TMP("XNNEW",$J,YSKFDFN,NXTDT)=2 S X1=+^UTILITY($J,"FIRSTOP",YSKFDFN),X2=-90 D C^%DTC S YSKF90=(X-.001),STOP=1,^TMP("CHKDT",$J,YSKFDFN)=2_U_NXTDT_U_YSKF90 Q
19 .I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=2 S X1=+^UTILITY($J,"FIRSTOP",YSKFDFN),X2=-90 D C^%DTC S YSKF90=(X-.001),^TMP("CHKDT",$J,YSKFDFN)=2_U_+^UTILITY($J,"FIRSTOP",YSKFDFN)_U_YSKF90 D
20 .. S NXTDT=YSKF90 F S NXTDT=$O(^TMP("XNNEW",$J,YSKFDFN,NXTDT)) Q:NXTDT'>0!(STOP=1) D ;back up to find previous entries
21 ...I NXTDT=+^UTILITY($J,"FIRSTOP",YSKFDFN) S STOP=1 Q ;no previous entries
22 ...S X1=NXTDT,X2=-90 D C^%DTC S YSKF90=(X-.001)
23 ...I +^TMP("XNNEW",$J,YSKFDFN,NXTDT)=1 S STOP=1,^TMP("CHKDT",$J,YSKFDFN)=1_U_NXTDT_U_YSKF90
24 .S PT=+^TMP("CHKDT",$J,YSKFDFN)
25 .S YSKFDT=$P(^TMP("CHKDT",$J,YSKFDFN),"^",2),YSKF90=$P(^TMP("CHKDT",$J,YSKFDFN),"^",3)
26 . D NEW1 ;if ^tmp("x90",$j,YSKFdfn) not set, then new patient
27 .I '$D(^TMP("X90",$J,YSKFDFN)) S ^TMP("ASICHKDT",$J,YSKFDFN)=PT_U_YSKFDT_U_YSKF90
28 Q
29 ;
30NEW1 I '$D(^DGPT("B",YSKFDFN)) G NEW2
31 I '$D(^TMP("24STAY",$J,YSKFDFN)) G NEW2
32 S ADMT=YSKF90 F S ADMT=$O(^DGPT("AAD",YSKFDFN,ADMT)) Q:ADMT>YSKFDT!(ADMT'>0) S YSKFIEN=0 F S YSKFIEN=$O(^DGPT("AAD",YSKFDFN,ADMT,YSKFIEN)) Q:YSKFIEN="" D
33 .I $D(^DGPT(YSKFIEN,535,0)) S PHYSMV=0 F S PHYSMV=$O(^DGPT(YSKFIEN,535,PHYSMV)) Q:PHYSMV'>0 Q:'$D(^DGPT(YSKFIEN,535,PHYSMV,0)) I $D(WARD(+$P(^DGPT(YSKFIEN,535,PHYSMV,0),U,2))) D
34 ..I ADMT'=YSKFDT S ^TMP("X90",$J,YSKFDFN,ADMT,1)=1_U_+$P(^DGPT(YSKFIEN,535,PHYSMV,0),U,2) ;PC 8/3/01
35 .I $D(^DGPT(YSKFIEN,"M",0)) S MOVE=0 F S MOVE=$O(^DGPT(YSKFIEN,"M",MOVE)) Q:MOVE'>0 Q:'$D(^DGPT(YSKFIEN,"M",MOVE,0)) I $D(WARD(+$P(^DGPT(YSKFIEN,"M",MOVE,0),U,2))) D
36 ..I ADMT'=YSKFDT S ^TMP("X90",$J,YSKFDFN,ADMT,1)=1_U_+$P(^DGPT(YSKFIEN,"M",MOVE,0),U,2) ; PC 8/3/01 visit/stay in mental health
37 ;
38NEW2 ;find encounters in sub abuse clinics
39 I $D(^TMP("X90",$J,YSKFDFN)) Q
40 I ($G(^UTILITY($J,"OPT",YSKFDFN))<3)&('$D(^TMP("24STAY",$J,YSKFDFN))) S ^TMP("X90",$J,YSKFDFN,YSKFDT,2)=2 Q ;not 3 visits and no 24hr stay,then not new
41 ;
42 S FND=0,YSKFECDT=YSKF90 F S YSKFECDT=$O(^SCE("ADFN",YSKFDFN,YSKFECDT)) Q:YSKFECDT=""!(FND=1)!(YSKFECDT>YSKFDT) S YSKFENC=0 F S YSKFENC=$O(^SCE("ADFN",YSKFDFN,YSKFECDT,YSKFENC)) Q:YSKFENC="" D
43 .Q:'$D(^SCE(YSKFENC,0))
44 .Q:$P(^SCE(YSKFENC,0),U,12)=8 Q:$P(^(0),U,12)=12 ;PC 6/28/01
45 .I $D(CLINIC(+$P(^SCE(YSKFENC,0),U,3))) D
46 ..I YSKFECDT'=YSKFDT S ^TMP("X90",$J,YSKFDFN,YSKFECDT,YSKFENC)=2_U_+$P(^SCE(YSKFENC,0),U,3),FND=1 ;PC 8/3/01 visit/stay in mental health
47 Q
48ASI ;determine if ASI done
49 S YSKFDFN=0 F S YSKFDFN=$O(^TMP("ASICHKDT",$J,YSKFDFN)) Q:YSKFDFN'>0 S YSKFDT=$P(^TMP("ASICHKDT",$J,YSKFDFN),"^",2),PT=+^TMP("ASICHKDT",$J,YSKFDFN) D
50 .I PT=1 D
51 ..I '$D(^TMP("24STAY",$J,YSKFDFN)) Q
52 ..S X1=YSKFDT,X2=14 D C^%DTC S CHKDT=X S:CHKDT>TODAY ^TMP("UNKASI",$J,YSKFDFN)="" I '$D(^TMP("XN",$J,"ASI",YSKFDFN)) S PT=1 D ASI0
53 .I PT=2 D
54 ..I $D(^TMP("XN",$J,"ASI",YSKFDFN)) Q
55 ..I ($D(^UTILITY($J,"TRDOP",YSKFDFN))) D
56 ...S FIRSTDT=+$G(^UTILITY($J,"FIRSTOP",YSKFDFN)) S X1=+^UTILITY($J,"TRDOP",YSKFDFN) S X2=14 D C^%DTC S CHKDT=X
57 ...S:CHKDT>TODAY ^TMP("UNKASI",$J,YSKFDFN)=""
58 ..D ASI0 ;PC 8/3/01
59 .I PT=2&('$D(^UTILITY($J,"TRDOP",YSKFDFN)))&($D(^TMP("24STAY",$J,YSKFDFN))) D ;if not 3 visits but 24 hr stay, check ASI
60 ..S ASI=0,INDATE=YSKFDT F S INDATE=$O(^TMP("XN",$J,YSKFDFN,INDATE)) Q:INDATE'>0!(ASI=1) S YSKFDT=INDATE D ;PC 8/3/01
61 ...S X1=YSKFDT,X2=14 D C^%DTC S CHKDT=X
62 ...S:CHKDT>TODAY ^TMP("UNKASI",$J,YSKFDFN)=""
63 ...I '$D(^TMP("XN",$J,"ASI",YSKFDFN)) S PT=1 D ASI0
64NOASI ;
65 S YSKFDFN=0 F S YSKFDFN=$O(^TMP("XN",$J,YSKFDFN)) Q:YSKFDFN'>0 I '$D(^TMP("XN",$J,"ASI",YSKFDFN)) S YSKFDT=0 F S YSKFDT=$O(^TMP("XN",$J,YSKFDFN,YSKFDT)) Q:YSKFDT'>0 D
66 .I $D(^TMP("UNKASI",$J,YSKFDFN)) S ^TMP("SHORT",$J,YSKFDFN)=^TMP("XN",$J,YSKFDFN,YSKFDT)_U_YSKFDT Q
67 .I YSKFDT<(TODAY_.9999) S ^TMP("XN1",$J,YSKFDFN,YSKFDT,1)=^TMP("XN",$J,YSKFDFN,YSKFDT)
68 S YSKFDFN=0 F S YSKFDFN=$O(^TMP("XNOPT",$J,YSKFDFN)) Q:YSKFDFN'>0 I '$D(^TMP("XN",$J,"ASI",YSKFDFN)) S YSKFDT=0 F S YSKFDT=$O(^TMP("XNOPT",$J,YSKFDFN,YSKFDT)) Q:YSKFDT'>0 S ENC=0 F S ENC=$O(^TMP("XNOPT",$J,YSKFDFN,YSKFDT,ENC)) Q:ENC'>0 D
69 .I $D(^TMP("UNKASI",$J,YSKFDFN)) S ^TMP("SHORT",$J,YSKFDFN)=^TMP("XNOPT",$J,YSKFDFN,YSKFDT,ENC)_U_YSKFDT_U_$G(^UTILITY($J,"TRDOP",YSKFDFN)) Q
70 .I YSKFDT<(TODAY_.9999) S ^TMP("XN1",$J,YSKFDFN,YSKFDT,ENC)=^TMP("XNOPT",$J,YSKFDFN,YSKFDT,ENC)
71 ;
72 Q
73ASI0 ;
74 S YSKFASI=0 F S YSKFASI=$O(^YSTX(604,"C",YSKFDFN,YSKFASI)) Q:YSKFASI'>0 D
75 .S YSKFSP=0
76 .;YSKFASDT=interview date, YSKFCLS=class, YSKFSP=special
77 .S YSKFASDT=$P($G(^YSTX(604,YSKFASI,0)),U,5)
78 .S TSTMONTH=+$E(YSKFASDT,4,5)
79 .I PT=1 D
80 ..S X1=YSKFDT,X2=-30 D C^%DTC S CHKDT30=X
81 ..I ((YSKFASDT>(CHKDT30-.001))&(YSKFASDT<(CHKDT+.999))) D
82 ...S YSKFSP=$P($G(^YSTX(604,YSKFASI,0)),U,11) I YSKFSP=1!(YSKFSP=2)!(YSKFSP=3) D
83 ....S YSKFSP=$S(YSKFSP=1:"Terminated",YSKFSP=2:"Refused",YSKFSP=3:"Unable to respond",1:"") ;pt terminated or refused
84 ...S YSKFCLS=$P($G(^YSTX(604,YSKFASI,0)),U,4)
85 ...S YSKFASD=$E(YSKFASDT,4,5)_"/"_$E(YSKFASDT,6,7)_"/"_$E(YSKFASDT,2,3)
86 ...S ^TMP("XN",$J,"ASI",YSKFDFN)=PT_U_YSKFDT_U_YSKFCLS_U_YSKFSP_U_TSTMONTH_U_YSKFASD_U_YSKFASDT_U_$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),"^",2) S ASI=1 Q
87 .; code change to look for ASI 30 days prior to first opt visit
88 .I PT=2 I $D(^UTILITY($J,"TRDOP",YSKFDFN)) D
89 ..S X1=FIRSTDT,X2=-30 D C^%DTC S CHKDT30=X
90 ..I ((YSKFASDT>(CHKDT30-.001))&(YSKFASDT<(CHKDT+.999))) D
91 ...S YSKFSP=$P($G(^YSTX(604,YSKFASI,0)),U,11) I YSKFSP=1!(YSKFSP=2)!(YSKFSP=3) D
92 ....S YSKFSP=$S(YSKFSP=1:"Terminated",YSKFSP=2:"Refused",YSKFSP=3:"Unable to respond",1:"") ;pt terminated or refused
93 ...S YSKFCLS=$P($G(^YSTX(604,YSKFASI,0)),U,4)
94 ...S YSKFASD=$E(YSKFASDT,4,5)_"/"_$E(YSKFASDT,6,7)_"/"_$E(YSKFASDT,2,3)
95 ...S ^TMP("XN",$J,"ASI",YSKFDFN)=PT_U_YSKFDT_U_YSKFCLS_U_YSKFSP_U_TSTMONTH_U_YSKFASD_U_YSKFASDT_U_$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),"^",2) S ASI=1 Q
96 ;
Note: See TracBrowser for help on using the repository browser.