source: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSKFASI3.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: 7.0 KB
Line 
1YSKFASI3 ;16IT/PTC - SUBSTANCE ABUSE ;6/22/01 14:21
2 ;;5.01;MENTAL HEALTH;**73**;Dec 30, 1994
3 ;
4 ;Reference to ^DIC(40.7 supported by DBIA #1024
5 ;Reference to ^DIC(42.4 supported by DBIA #557
6 ;Reference to ^DPT( supported by DBIA #10035
7 ;
8 ;TOTALS
9 S (NEW,ASI,NOASI,MAYBE,G12)=0 ;ASF 6/20/01
10 S (CKCTT,YSKFDFN)=0 F S YSKFDFN=$O(^TMP("XNNEW",$J,YSKFDFN)) Q:YSKFDFN'>0 I ($G(^UTILITY($J,"OPT",YSKFDFN))>2)!($D(^TMP("24STAY",$J,YSKFDFN))) S CKCTT=CKCTT+1 D
11 .I '$D(^TMP("X90",$J,YSKFDFN)) S NEW=NEW+1 S YSKFDT=$O(^TMP("XNNEW",$J,YSKFDFN,4001231),-1) D
12 ..I $D(^TMP("SHORT",$J,YSKFDFN))&('$D(^TMP("XN",$J,"ASI",YSKFDFN))) S MAYBE=MAYBE+1 D ALPHA1
13 ..I $D(^TMP("XN",$J,"ASI",YSKFDFN))&($P($G(^TMP("XN",$J,"ASI",YSKFDFN)),U,4)="N") S ASI=ASI+1,FLGASI=1,TYPE=+^TMP("XN",$J,"ASI",YSKFDFN) D ALPHA ;G12 CHECK ASF 6/20/01
14 ..I $D(^TMP("XN",$J,"ASI",YSKFDFN))&($P($G(^TMP("XN",$J,"ASI",YSKFDFN)),U,4)'="N") S G12=G12+1,FLGASI=1,TYPE=+^TMP("XN",$J,"ASI",YSKFDFN) D ALPHA ;G12 CHECK ASF 6/20/01
15 ..I '$D(^TMP("XN",$J,"ASI",YSKFDFN))&('$D(^TMP("SHORT",$J,YSKFDFN))) S NOASI=NOASI+1,FLGASI=0 S YSKFDT1=$O(^TMP("XNNEW",$J,YSKFDFN,"A"),-1) S TYPE=+^TMP("XNNEW",$J,YSKFDFN,YSKFDT) S SAVEDT=YSKFDT,YSKFDT=YSKFDT1 D ALPHA S YSKFDT=SAVEDT K SAVEDT
16 ;
17LIST ; patient w/o ASI
18 S YSKFJCNT=0
19 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" NEW PATIENTS WITHOUT ASI (date is stay or 3rd visit during date range)"
20 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
21 S NAME="" F S NAME=$O(^TMP("RPT",$J,NAME)) Q:NAME="" S YSKFDFN=0 F S YSKFDFN=$O(^TMP("RPT",$J,NAME,YSKFDFN)) Q:YSKFDFN'>0 D
22 .S NODE=^TMP("RPT",$J,NAME,YSKFDFN) F I=1:1:6 S P(I)=$P(NODE,U,I)
23 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(1)_P(2)_" "_P(4)_" "_P(6)
24 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(3)_" "_P(5)
25 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
26 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" NEW PATIENTS WITHOUT ASI BUT 14TH DAY NOT REACHED"
27 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
28 I $D(^TMP("MAYBE",$J)) S NAME="" F S NAME=$O(^TMP("MAYBE",$J,NAME)) Q:NAME="" S YSKFDFN=0 F S YSKFDFN=$O(^TMP("MAYBE",$J,NAME,YSKFDFN)) Q:YSKFDFN="" D
29 .S NODE=^TMP("MAYBE",$J,NAME,YSKFDFN) F I=1:1:5 S P(I)=$P(NODE,U,I)
30 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(1)_P(2)_" "_P(4)
31 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(3)_" "_P(5)
32 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
33 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" NEW PATIENTS WITH ASI (date is ASI interview date)"
34 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="Sorted by Followup Months"
35 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
36 S NXT=0 F S NXT=$O(^TMP("RPT1",$J,NXT)) Q:NXT'>0 S NAME="" F S NAME=$O(^TMP("RPT1",$J,NXT,NAME)) Q:NAME="" S YSKFDFN=0 F S YSKFDFN=$O(^TMP("RPT1",$J,NXT,NAME,YSKFDFN)) Q:YSKFDFN'>0 D
37 .S NODE=^TMP("RPT1",$J,NXT,NAME,YSKFDFN) F I=1:1:7 S P(I)=$P(NODE,U,I)
38 .S XNXT=$$DATE(NXT)
39 .S P(7)=$$DATE(P(7))
40 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=XNXT_"-"_P(7)_" "_P(1)_" "_P(2)_" "_P(4)_" "_P(6)
41 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(3)_" "_P(5)
42 .S ^TMP("FOLLUP",$J,YSKFDFN)=^TMP("FOLLUP",$J,YSKFDFN)_U_XNXT_U_P(7)
43 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
44 D ^YSKFASIF
45 D ^YSKFASIP
46 Q
47ALPHA ;
48 S NAME=$P(^DPT(YSKFDFN,0),U,1),SSN=$P(^(0),U,9)
49 S PRTNAME=NAME S YSKFL=$L(PRTNAME),YSKFLM=25-YSKFL F YSKFLCNT=1:1:YSKFLM S PRTNAME=PRTNAME_" "
50 ;I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=1 D
51 I TYPE=1 D
52 . I FLGASI=0 D
53 ..S WARD=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,2) I WARD]"" S WARD=$P(^DIC(42.4,WARD,0),U)
54 ..S ADMIT=$E(YSKFDT,4,5)_"/"_$E(YSKFDT,6,7)_"/"_$E(YSKFDT,2,3)
55 ..S SPECIAL=$P($G(^TMP("XN",$J,"ASI",YSKFDFN)),"^",4)
56 ..I SPECIAL="N" S SPECIAL=""
57 ..S ^TMP("RPT",$J,NAME,YSKFDFN)=PRTNAME_U_SSN_U_WARD_U_ADMIT_U_U_SPECIAL
58 .I FLGASI=1 S MON=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",5) D
59 ..I MON<6 S NXT=MON+5,NXT2=MON+7
60 ..I MON=6 S NXT=MON+5,NXT2=1
61 ..I MON=7 S NXT=MON+5,NXT2=2
62 ..I MON=8 S NXT=1,NXT2=3
63 ..I MON=9 S NXT=2,NXT2=4
64 ..I MON=10 S NXT=3,NXT2=5
65 ..I MON=11 S NXT=4,NXT2=6
66 ..I MON=12 S NXT=5,NXT2=7
67 ..S WARD=$P(^TMP("XN",$J,"ASI",YSKFDFN),U,8) I WARD]"" S WARD=$P(^DIC(42.4,WARD,0),U)
68 ..S ADMIT=$E(YSKFDT,4,5)_"/"_$E(YSKFDT,6,7)_"/"_$E(YSKFDT,2,3)
69 ..S SPECIAL=$P($G(^TMP("XN",$J,"ASI",YSKFDFN)),"^",4)
70 ..I SPECIAL="N" S SPECIAL=""
71 ..S ASIDATE=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",6)
72 ..S ASIDATE1=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",7)
73 ..S ^TMP("RPT1",$J,NXT,NAME,YSKFDFN)=PRTNAME_U_SSN_U_WARD_U_ASIDATE_U_U_SPECIAL_U_NXT2
74 ..S ^TMP("FOLLUP",$J,YSKFDFN)=NXT_U_NXT2_U_ASIDATE1
75 ;I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=2 D
76 I TYPE=2 D
77 .I FLGASI=0 D
78 ..S CLIN=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,2) I CLIN]"" S CLIN=$P(^DIC(40.7,CLIN,0),U)
79 ..S PRVDER=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,3)
80 ..S LSTVST=$S($D(^UTILITY($J,"TRDOP",YSKFDFN)):+^UTILITY($J,"TRDOP",YSKFDFN),1:YSKFDT)
81 ..S LSTVSTPR=$E(LSTVST,4,5)_"/"_$E(LSTVST,6,7)_"/"_$E(LSTVST,2,3)
82 .I FLGASI=1 D
83 ..S CLIN=$P(^TMP("XN",$J,"ASI",YSKFDFN),U,8) I CLIN]"" S CLIN=$P(^DIC(40.7,CLIN,0),U)
84 ..S PRVDER=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,3)
85 ..S ENCDT=$E(YSKFDT,4,5)_"/"_$E(YSKFDT,6,7)_"/"_$E(YSKFDT,2,3)
86 ..S ASIDATE=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",6)
87 ..S ASIDATE1=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",7)
88 .S SPECIAL=$P($G(^TMP("XN",$J,"ASI",YSKFDFN)),"^",4)
89 .I SPECIAL="N" S SPECIAL=""
90 .I FLGASI=0 S ^TMP("RPT",$J,NAME,YSKFDFN)=PRTNAME_U_SSN_U_CLIN_U_LSTVSTPR_U_PRVDER_U_SPECIAL
91 .I FLGASI=1 S MON=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",5) D
92 ..I MON<6 S NXT=MON+5,NXT2=MON+7
93 ..I MON=6 S NXT=MON+5,NXT2=1
94 ..I MON=7 S NXT=MON+5,NXT2=2
95 ..I MON=8 S NXT=1,NXT2=3
96 ..I MON=9 S NXT=2,NXT2=4
97 ..I MON=10 S NXT=3,NXT2=5
98 ..I MON=11 S NXT=4,NXT2=6
99 ..I MON=12 S NXT=5,NXT2=7
100 ..S ASIDATE=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",6)
101 ..S ASIDATE1=$P(^TMP("XN",$J,"ASI",YSKFDFN),"^",7)
102 ..S ^TMP("RPT1",$J,NXT,NAME,YSKFDFN)=PRTNAME_U_SSN_U_CLIN_U_ASIDATE_U_PRVDER_U_SPECIAL_U_NXT2
103 ..S ^TMP("FOLLUP",$J,YSKFDFN)=NXT_U_NXT2_U_ASIDATE1
104 Q
105DATE(X) ;
106 S X=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+X)
107 Q X
108ALPHA1 ;
109 S NAME=$P(^DPT(YSKFDFN,0),U,1),SSN=$P(^(0),U,9)
110 S PRTNAME=NAME S YSKFL=$L(PRTNAME),YSKFLM=25-YSKFL F YSKFLCNT=1:1:YSKFLM S PRTNAME=PRTNAME_" "
111 I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=1 D
112 .S WARD=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,2) I WARD]"" S WARD=$P(^DIC(42.4,WARD,0),U)
113 .S ADMIT=$E(YSKFDT,4,5)_"/"_$E(YSKFDT,6,7)_"/"_$E(YSKFDT,2,3)
114 .S ^TMP("MAYBE",$J,NAME,YSKFDFN)=PRTNAME_U_SSN_U_WARD_U_ADMIT
115 I +^TMP("XNNEW",$J,YSKFDFN,YSKFDT)=2 D
116 .S CLIN=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,2) I CLIN]"" S CLIN=$P(^DIC(40.7,CLIN,0),U)
117 .S PRVDER=$P(^TMP("XNNEW",$J,YSKFDFN,YSKFDT),U,3)
118 .S ENCDT=$E(YSKFDT,4,5)_"/"_$E(YSKFDT,6,7)_"/"_$E(YSKFDT,2,3)
119 .S TRDVST=$P(^TMP("SHORT",$J,YSKFDFN),U,5)
120 .S TRDVSTD=$E(TRDVST,4,5)_"/"_$E(TRDVST,6,7)_"/"_$E(TRDVST,2,3)
121 .S ^TMP("MAYBE",$J,NAME,YSKFDFN)=PRTNAME_U_SSN_U_CLIN_U_TRDVSTD_U_PRVDER
122 Q
Note: See TracBrowser for help on using the repository browser.