source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSKFASIF.m@ 1154

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1YSKFASIF ;16IT/PTC - SUBSTANCE ABUSE FOLLOWUP ;6/28/01 14:31
2 ;;5.01;MENTAL HEALTH;**73**;Dec 30, 1994
3 ;
4 ;Reference to ^DPT( supported by DBIA #10035
5 ;
6START D NOW^%DTC S TODAY=X
7 ;
8 S (FOLLCT,YSKFDFN)=0 F S YSKFDFN=$O(^TMP("FOLLUP",$J,YSKFDFN)) Q:YSKFDFN="" S FOLLCT=FOLLCT+1,NXT=$P(^TMP("FOLLUP",$J,YSKFDFN),"^"),NXT2=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",2) D
9 .S ASIDT=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",3)
10 .;GET START DATE FROM NXT AND END DATE FROM NXT2
11 .S:$L(NXT)<2 NXT="0"_NXT S:$L(NXT2)<2 NXT2="0"_NXT2
12 .I $E(ASIDT,4,5)<8 S NXTDT=$E(ASIDT,1,3)_NXT_"01"
13 .I $E(ASIDT,4,5)>7 S NXTDT=($E(ASIDT,1,3)+1)_NXT_"01"
14 .I NXT<11 S NXT2DT=$E(NXTDT,1,3)_NXT2
15 .I NXT>10 S NXT2DT=($E(NXTDT,1,3)+1)_NXT2
16 .S X=+NXT2,X=$S("^1^3^5^7^8^10^12^"[(U_X_U):31,X'=2:30,$E(NXT2DT,1,3)#4:28,1:29) S NXT2DT=NXT2DT_X
17 .S $P(^TMP("FOLLUP",$J,YSKFDFN),"^",6)=NXTDT
18 .S $P(^TMP("FOLLUP",$J,YSKFDFN),"^",7)=NXT2DT
19 .D ASI0
20 ;
21NOASI ;
22 S (FOLLG12,FOLLDONE,FOLLSHR,NOFOLLCT,YSKFDFN)=0 F S YSKFDFN=$O(^TMP("FOLLUP",$J,YSKFDFN)) Q:YSKFDFN="" D ;ASF/6/15/01
23 .I '$D(^TMP("FOLLASI",$J,YSKFDFN)) S NXTDT=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",6),NXT2DT=$P(^(YSKFDFN),"^",7) D
24 ..I TODAY<NXTDT!(TODAY<NXT2DT) S ^UTILITY($J,"EARLY",YSKFDFN)=^TMP("FOLLUP",$J,YSKFDFN),FOLLSHR=FOLLSHR+1 S SHORT=1 D ALPHA Q
25 ..S NOFOLLCT=NOFOLLCT+1 S SHORT=0 D ALPHA
26 .I $D(^TMP("FOLLASI",$J,YSKFDFN))&($P($G(TMP("FOLLASI",$J,YSKFDFN)),U,2)="N") S FOLLDONE=FOLLDONE+1 ;ASF 6/15/01
27 .I $D(^TMP("FOLLASI",$J,YSKFDFN))&($P($G(TMP("FOLLASI",$J,YSKFDFN)),U,2)?1N) S FOLLG12=FOLLG12+1 ;ASF 6/15/01
28 ;
29CALC ;
30 S FOLLSHRP=$S(FOLLCT'=0:((FOLLSHR/FOLLCT)*100),1:" .") ;EARLY
31 S FOLLDONP=$S(FOLLCT'=0:((FOLLDONE/FOLLCT)*100),1:" .") ;DONE
32 S FOLLG12P=$S(FOLLCT'=0:((FOLLG12/FOLLCT)*100),1:" .") ;DONE BUT G12 ASF 6/15/01
33 S NOFOLLP=$S(FOLLCT'=0:((NOFOLLCT/FOLLCT)*100),1:" .") ;NOT DONE
34 ;
35LIST ; patient w/o FOLLUP ASI
36 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" PATIENTS WITHOUT FOLLOWUP ASI"
37 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
38 I $D(^TMP("PTNOFOLL",$J)) S MON="" F S MON=$O(^TMP("PTNOFOLL",$J,MON)) Q:MON="" S NAME="" F S NAME=$O(^TMP("PTNOFOLL",$J,MON,NAME)) Q:NAME="" S YSKFDFN=0 F S YSKFDFN=$O(^TMP("PTNOFOLL",$J,MON,NAME,YSKFDFN)) Q:YSKFDFN'>0 D
39 .S NODE=^TMP("PTNOFOLL",$J,MON,NAME,YSKFDFN) F I=1:1:4 S P(I)=$P(NODE,U,I)
40 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(1)_P(2)_" DUE: "_P(3)_" - "_P(4)
41 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
42 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" PATIENTS WITHOUT FOLLOWUP ASI; TIME NOT EXPIRED"
43 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
44 I $D(^TMP("SHORTFOLL",$J)) S MON="" F S MON=$O(^TMP("SHORTFOLL",$J,MON)) Q:MON="" S NAME="" F S NAME=$O(^TMP("SHORTFOLL",$J,MON,NAME)) Q:NAME="" S YSKFDFN=0 F S YSKFDFN=$O(^TMP("SHORTFOLL",$J,MON,NAME,YSKFDFN)) Q:YSKFDFN="" D
45 .S NODE=^TMP("SHORTFOLL",$J,MON,NAME,YSKFDFN) F I=1:1:4 S P(I)=$P(NODE,U,I)
46 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" "_P(1)_P(2)_" DUE: "_P(3)_" - "_P(4)
47 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
48 Q
49ASI0 ;
50 S (ASIF,YSKFASI)=0 F S YSKFASI=$O(^YSTX(604,"C",YSKFDFN,YSKFASI)) Q:YSKFASI'>0!(ASIF=1) D
51 .S YSKFSP=0
52 .;YSKFASDT=interview date, YSKFCLS=class, YSKFSP=special
53 .S YSKFSP=$P($G(^YSTX(604,YSKFASI,0)),U,11) ;ASF 6/28/01
54 .S YSKFASDT=$P($G(^YSTX(604,YSKFASI,0)),U,5)
55 .I ((YSKFASDT>(NXTDT-.001))&(YSKFASDT<(NXT2DT+.999))) D
56 ..S YSKFASDT=$E(YSKFASDT,4,5)_"/"_$E(YSKFASDT,6,7)_"/"_$E(YSKFASDT,2,3)
57 ..S ^TMP("FOLLASI",$J,YSKFDFN)=YSKFASDT_U_YSKFSP,ASIF=1 Q ;ASF 6/15/01
58 Q
59ALPHA ;
60 S NAME=$P(^DPT(YSKFDFN,0),U,1),SSN=$P(^(0),U,9)
61 S PRTNAME=NAME S YSKFL=$L(PRTNAME),YSKFLM=25-YSKFL F YSKFLCNT=1:1:YSKFLM S PRTNAME=PRTNAME_" "
62 S DAY1=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",1),DAY1MON=$$DATE(DAY1)
63 S DAY2=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",2),DAY2MON=$$DATE(DAY2)
64 I SHORT=0 S ^TMP("PTNOFOLL",$J,DAY1,NAME,YSKFDFN)=PRTNAME_U_SSN_U_DAY1MON_U_DAY2MON
65 I SHORT=1 S ^TMP("SHORTFOLL",$J,DAY1,NAME,YSKFDFN)=PRTNAME_U_SSN_U_DAY1MON_U_DAY2MON
66 Q
67DATE(X) ;
68 S X=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+X)
69 Q X
Note: See TracBrowser for help on using the repository browser.