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

YSKFASIF ;16IT/PTC - SUBSTANCE ABUSE FOLLOWUP  ;6/28/01  14:31
 ;;5.01;MENTAL HEALTH;**73**;Dec 30, 1994
 ;
 ;Reference to ^DPT( supported by DBIA #10035
 ;
START D NOW^%DTC S TODAY=X
 ;
 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
 .S ASIDT=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",3)
 .;GET START DATE FROM NXT AND END DATE FROM NXT2
 .S:$L(NXT)<2 NXT="0"_NXT S:$L(NXT2)<2 NXT2="0"_NXT2
 .I $E(ASIDT,4,5)<8 S NXTDT=$E(ASIDT,1,3)_NXT_"01"
 .I $E(ASIDT,4,5)>7 S NXTDT=($E(ASIDT,1,3)+1)_NXT_"01"
 .I NXT<11 S NXT2DT=$E(NXTDT,1,3)_NXT2
 .I NXT>10 S NXT2DT=($E(NXTDT,1,3)+1)_NXT2
 .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
 .S $P(^TMP("FOLLUP",$J,YSKFDFN),"^",6)=NXTDT
 .S $P(^TMP("FOLLUP",$J,YSKFDFN),"^",7)=NXT2DT
 .D ASI0
 ;
NOASI ;
 S (FOLLG12,FOLLDONE,FOLLSHR,NOFOLLCT,YSKFDFN)=0 F  S YSKFDFN=$O(^TMP("FOLLUP",$J,YSKFDFN)) Q:YSKFDFN=""  D  ;ASF/6/15/01
 .I '$D(^TMP("FOLLASI",$J,YSKFDFN)) S NXTDT=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",6),NXT2DT=$P(^(YSKFDFN),"^",7) D
 ..I TODAY<NXTDT!(TODAY<NXT2DT) S ^UTILITY($J,"EARLY",YSKFDFN)=^TMP("FOLLUP",$J,YSKFDFN),FOLLSHR=FOLLSHR+1 S SHORT=1 D ALPHA Q
 ..S NOFOLLCT=NOFOLLCT+1 S SHORT=0 D ALPHA
 .I $D(^TMP("FOLLASI",$J,YSKFDFN))&($P($G(TMP("FOLLASI",$J,YSKFDFN)),U,2)="N") S FOLLDONE=FOLLDONE+1 ;ASF 6/15/01
 .I $D(^TMP("FOLLASI",$J,YSKFDFN))&($P($G(TMP("FOLLASI",$J,YSKFDFN)),U,2)?1N) S FOLLG12=FOLLG12+1 ;ASF 6/15/01
 ;
CALC ;
 S FOLLSHRP=$S(FOLLCT'=0:((FOLLSHR/FOLLCT)*100),1:"   .")  ;EARLY
 S FOLLDONP=$S(FOLLCT'=0:((FOLLDONE/FOLLCT)*100),1:"   .") ;DONE
 S FOLLG12P=$S(FOLLCT'=0:((FOLLG12/FOLLCT)*100),1:"   .") ;DONE BUT G12 ASF 6/15/01
 S NOFOLLP=$S(FOLLCT'=0:((NOFOLLCT/FOLLCT)*100),1:"   .")  ;NOT DONE
 ;
LIST ; patient w/o FOLLUP ASI
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="  PATIENTS WITHOUT FOLLOWUP ASI"
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
 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
 .S NODE=^TMP("PTNOFOLL",$J,MON,NAME,YSKFDFN) F I=1:1:4 S P(I)=$P(NODE,U,I)
 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="   "_P(1)_P(2)_" DUE:  "_P(3)_" - "_P(4)
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=" PATIENTS WITHOUT FOLLOWUP ASI;  TIME NOT EXPIRED"
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="==============================================================================="
 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
 .S NODE=^TMP("SHORTFOLL",$J,MON,NAME,YSKFDFN) F I=1:1:4 S P(I)=$P(NODE,U,I)
 .S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)="   "_P(1)_P(2)_" DUE: "_P(3)_" - "_P(4)
 S YSKFJCNT=YSKFJCNT+1,^TMP("XM",$J,YSKFJCNT)=""
 Q
ASI0 ;
 S (ASIF,YSKFASI)=0 F  S YSKFASI=$O(^YSTX(604,"C",YSKFDFN,YSKFASI)) Q:YSKFASI'>0!(ASIF=1)  D
 .S YSKFSP=0
 .;YSKFASDT=interview date, YSKFCLS=class, YSKFSP=special
 .S YSKFSP=$P($G(^YSTX(604,YSKFASI,0)),U,11) ;ASF 6/28/01
 .S YSKFASDT=$P($G(^YSTX(604,YSKFASI,0)),U,5)
 .I ((YSKFASDT>(NXTDT-.001))&(YSKFASDT<(NXT2DT+.999))) D
 ..S YSKFASDT=$E(YSKFASDT,4,5)_"/"_$E(YSKFASDT,6,7)_"/"_$E(YSKFASDT,2,3)
 ..S ^TMP("FOLLASI",$J,YSKFDFN)=YSKFASDT_U_YSKFSP,ASIF=1 Q  ;ASF 6/15/01
 Q
ALPHA ;
 S NAME=$P(^DPT(YSKFDFN,0),U,1),SSN=$P(^(0),U,9)
 S PRTNAME=NAME S YSKFL=$L(PRTNAME),YSKFLM=25-YSKFL F YSKFLCNT=1:1:YSKFLM S PRTNAME=PRTNAME_" "
 S DAY1=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",1),DAY1MON=$$DATE(DAY1)
 S DAY2=$P(^TMP("FOLLUP",$J,YSKFDFN),"^",2),DAY2MON=$$DATE(DAY2)
 I SHORT=0 S ^TMP("PTNOFOLL",$J,DAY1,NAME,YSKFDFN)=PRTNAME_U_SSN_U_DAY1MON_U_DAY2MON
 I SHORT=1 S ^TMP("SHORTFOLL",$J,DAY1,NAME,YSKFDFN)=PRTNAME_U_SSN_U_DAY1MON_U_DAY2MON
 Q
DATE(X) ;
 S X=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+X)
 Q X