YSASFUR ;ASF/ASL ASI FOLLOWUP REQUIRED ;3/13/98 10:39
;;5.01;MENTAL HEALTH;**38,55**;Dec 30, 1994
MAIN ;
K ^TMP("YSAS",$J)
N DIR,DIRUT,G,G2,VA,X,X1,X2,Y,YS2G12,YSASAD1,YSASBDT,YSASCL,YSASCNT,YSASCNT2,YSASCNT3,YSASDLY,YSASDT,YSASEDT,YSASG12,YSASIN,YSASIN2,YSASITE,YSASN,YSASS,YSASTC,YSASTYP2,YSCK,YSIN1,YSIN2,YSINTER,YSLOC,YSNM,YSTOT
W @IOF,!?10,"Addiction Severity Index Followup Reminder",!
D DTRANGE Q:YSASBDT=""!(YSASEDT="") Q:(YSASDLY=0)
W !!,"Results returned via Mailman. Please queue this report for after hours."
QUEUE ;
K IOP,ZTIO,ZTSAVE
S ZTIO="",ZTSAVE("YSAS*")="",ZTRTN="ENQ^YSASFUR",ZTDESC="ASI Followup Reminder" D ^%ZTLOAD W:$D(ZTSK) !!,"Your Task Number is "_ZTSK D ^%ZISC
K ^TMP("YSAS",$J),^TMP("YSAS",$J,"G")
Q
ENQ ;queue entry
;S:$D(ZTQUEUED) ZTREQ="@"
S YSASN=0,YSTOT=0
D DATELP
D HEAD,PTLST,BOT
D MAIL2 ; output
Q
DTRANGE ;date range
W ! S (YSASBDT,YSASEDT)="",%DT("A")="Beginning Date for ASI Followup Reminder Date Range: ",%DT="AEX" D ^%DT
Q:Y'>0
S YSASBDT=+Y
W ! S %DT("A")="Ending Date for ASI Followup Reminder Date Range: " D ^%DT
Q:Y'>0
S YSASEDT=+Y
I (YSASEDT>0)&(YSASEDT<YSASBDT) W !,?7,"Ending Date must be closer to today than Beginning Date",! H 2 W $C(7) G DTRANGE
W ! K DIR S DIR(0)="N^31:999:0",DIR("B")=180,DIR("A")="Number of days after which a follow-up is required" D ^DIR S:$D(DIRUT) Y=0 S YSASDLY=Y K DIR
Q
DATELP ;look for all ASIs in range
S YSASDT=YSASBDT-.0001 F S YSASDT=$O(^YSTX(604,"AD",YSASDT)) Q:YSASDT>YSASEDT!(YSASDT'>0) S YSASIN=0 F S YSASIN=$O(^YSTX(604,"AD",YSASDT,YSASIN)) Q:YSASIN'>0 D
. S G=^YSTX(604,YSASIN,0),DFN=$P(G,U,2),YSASG12=$P(G,U,11),YSASCL=$P(G,U,4),YSASAD1=$P(G,U,5)
. Q:YSASG12'="N" ; only search on completes
. Q:DFN=""
. ;Q:YSASCL=3 ;it is a followup already
. S YSIN2=""
. D NEXTCK ;look for a fu
. S ^TMP("YSAS",$J,"A",$P(^DPT(DFN,0),U),DFN)=YSCK_U_YSASIN_U_YSIN2
Q
NEXTCK ;FU checker
S YSCK=0 ; DEFAULT= NEEDS FU
S X1=DT,X2=YSASAD1 D ^%DTC I X<YSASDLY S YSCK=-1 Q ; if first admin closer than delay
S YSASIN2=YSASIN F S YSASIN2=$O(^YSTX(604,"C",DFN,YSASIN2)) Q:YSASIN2'>0 D
. S G2=^YSTX(604,YSASIN2,0),YSASTYP2=$P(G2,U,4),YS2G12=$P(G,U,11),YSIN2=YSASIN2
. S YSCK=YSASTYP2
Q
PTLST ; list pts
S YSNM="" F S YSNM=$O(^TMP("YSAS",$J,"A",YSNM)) Q:YSNM="" S DFN=0 F S DFN=$O(^TMP("YSAS",$J,"A",YSNM,DFN)) Q:DFN'>0 D
. S G=^TMP("YSAS",$J,"A",YSNM,DFN),YSCK=+G,YSIN1=$P(G,U,2),YSIN2=$P(G,U,3)
. Q:YSCK=3 ; has a fU
. Q:YSCK=-1 ;admin less than delay
. D DEM^VADPT S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=$E(YSNM_YSASS,1,20)_" "_$E(VA("BID")_YSASS,1,6)_" "
. S YSTOT=YSTOT+1
. S G=^YSTX(604,YSIN1,0),YSASCL=$P(G,U,4),Y=$P(G,U,5) X ^DD("DD")
. S YSINTER=$P(G,U,9) S:YSINTER?1N.N YSINTER=$P($G(^VA(200,YSINTER,0)),U)
. S ^TMP("YSAS",$J,"G",YSASN)=^TMP("YSAS",$J,"G",YSASN)_$S(YSASCL=1:"Full",YSASCL=2:"Lite",YSASCL=3:"F-Up",1:" ")_" "_$E(Y_" ",1,13)_$E(YSINTER_YSASS,1,15)
. S ^TMP("YSAS",$J,"G",YSASN)=^TMP("YSAS",$J,"G",YSASN)_" "_$S(YSCK=1:" subsequent Full",YSCK=2:" subsequent Lite",1:"")
Q
HEAD ;header
K ^TMP("YSAS",$J,"G") S YSASS="",$P(YSASS," ",75)=""
;S YSASN=0,YSASITE=$P($G(^YSTX(604.8,1,0)),U) S:YSASITE'="" YSASITE=$P($G(^DIC(4,YSASITE,0)),U)
S YSASN=0
S YSASITE=$$SITE^YSASCF
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=$E(YSASS,1,15)_"Addiction Severity Index Followup Reminder"
S Y=YSASBDT\1 X ^DD("DD") S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=" Beginning Date: "_Y
S Y=YSASEDT\1 X ^DD("DD") S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=" Ending Date: "_Y
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)="Days to Follow-up: "_YSASDLY
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=" Facility: "_YSASITE
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=" "
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)="The following is a list of all patients who have not received followup ASI's"
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)="after completed interviews between the above dates."
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=$E(YSASS,1,34)_"Last ASI Administration in Range"
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)="Name"_$E(YSASS,1,17)_"SSN Type Date Interviewer"
Q
BOT ; bottom
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=" "
S YSASN=YSASN+1,^TMP("YSAS",$J,"G",YSASN)=YSTOT_" patients listed."
Q
MAIL2 ; SEND MAILMAN
K ^TMP("YSMM",$J)
S YSASCNT3=0,YSASTC=(YSASN\1000)+1
S YSASCNT=0,YSASCNT2=0 F S YSASCNT=$O(^TMP("YSAS",$J,"G",YSASCNT)) Q:(YSASCNT'>0) D
.S YSASCNT2=YSASCNT2+1,^TMP("YSMM",$J,YSASCNT)=^TMP("YSAS",$J,"G",YSASCNT)
.I (YSASCNT2=1000)!(YSASCNT=YSASN) D
..S YSASCNT3=YSASCNT3+1
..S DTIME=600
..S XMSUB="ASI Follow-up Reminder ("_YSASCNT3_" OF "_YSASTC_")"
..S XMTEXT="^TMP(""YSMM"",$J,"
..S XMY("G.ASI PERFORMANCE MEASURES")=""
..S XMY(DUZ)=""
..S XMDUZ="AUTOMATED MESSAGE"
..D ^XMD
..S YSASCNT2=0
..K ^TMP("YSMM",$J)
..S DTIME=$$DTIME^XUP(DUZ)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASFUR 4955 printed Nov 22, 2024@17:23:10 Page 2
YSASFUR ;ASF/ASL ASI FOLLOWUP REQUIRED ;3/13/98 10:39
+1 ;;5.01;MENTAL HEALTH;**38,55**;Dec 30, 1994
MAIN ;
+1 KILL ^TMP("YSAS",$JOB)
+2 NEW DIR,DIRUT,G,G2,VA,X,X1,X2,Y,YS2G12,YSASAD1,YSASBDT,YSASCL,YSASCNT,YSASCNT2,YSASCNT3,YSASDLY,YSASDT,YSASEDT,YSASG12,YSASIN,YSASIN2,YSASITE,YSASN,YSASS,YSASTC,YSASTYP2,YSCK,YSIN1,YSIN2,YSINTER,YSLOC,YSNM,YSTOT
+3 WRITE @IOF,!?10,"Addiction Severity Index Followup Reminder",!
+4 DO DTRANGE
if YSASBDT=""!(YSASEDT="")
QUIT
if (YSASDLY=0)
QUIT
+5 WRITE !!,"Results returned via Mailman. Please queue this report for after hours."
QUEUE ;
+1 KILL IOP,ZTIO,ZTSAVE
+2 SET ZTIO=""
SET ZTSAVE("YSAS*")=""
SET ZTRTN="ENQ^YSASFUR"
SET ZTDESC="ASI Followup Reminder"
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Your Task Number is "_ZTSK
DO ^%ZISC
+3 KILL ^TMP("YSAS",$JOB),^TMP("YSAS",$JOB,"G")
+4 QUIT
ENQ ;queue entry
+1 ;S:$D(ZTQUEUED) ZTREQ="@"
+2 SET YSASN=0
SET YSTOT=0
+3 DO DATELP
+4 DO HEAD
DO PTLST
DO BOT
+5 ; output
DO MAIL2
+6 QUIT
DTRANGE ;date range
+1 WRITE !
SET (YSASBDT,YSASEDT)=""
SET %DT("A")="Beginning Date for ASI Followup Reminder Date Range: "
SET %DT="AEX"
DO ^%DT
+2 if Y'>0
QUIT
+3 SET YSASBDT=+Y
+4 WRITE !
SET %DT("A")="Ending Date for ASI Followup Reminder Date Range: "
DO ^%DT
+5 if Y'>0
QUIT
+6 SET YSASEDT=+Y
+7 IF (YSASEDT>0)&(YSASEDT<YSASBDT)
WRITE !,?7,"Ending Date must be closer to today than Beginning Date",!
HANG 2
WRITE $CHAR(7)
GOTO DTRANGE
+8 WRITE !
KILL DIR
SET DIR(0)="N^31:999:0"
SET DIR("B")=180
SET DIR("A")="Number of days after which a follow-up is required"
DO ^DIR
if $DATA(DIRUT)
SET Y=0
SET YSASDLY=Y
KILL DIR
+9 QUIT
DATELP ;look for all ASIs in range
+1 SET YSASDT=YSASBDT-.0001
FOR
SET YSASDT=$ORDER(^YSTX(604,"AD",YSASDT))
if YSASDT>YSASEDT!(YSASDT'>0)
QUIT
SET YSASIN=0
FOR
SET YSASIN=$ORDER(^YSTX(604,"AD",YSASDT,YSASIN))
if YSASIN'>0
QUIT
Begin DoDot:1
+2 SET G=^YSTX(604,YSASIN,0)
SET DFN=$PIECE(G,U,2)
SET YSASG12=$PIECE(G,U,11)
SET YSASCL=$PIECE(G,U,4)
SET YSASAD1=$PIECE(G,U,5)
+3 ; only search on completes
if YSASG12'="N"
QUIT
+4 if DFN=""
QUIT
+5 ;Q:YSASCL=3 ;it is a followup already
+6 SET YSIN2=""
+7 ;look for a fu
DO NEXTCK
+8 SET ^TMP("YSAS",$JOB,"A",$PIECE(^DPT(DFN,0),U),DFN)=YSCK_U_YSASIN_U_YSIN2
End DoDot:1
+9 QUIT
NEXTCK ;FU checker
+1 ; DEFAULT= NEEDS FU
SET YSCK=0
+2 ; if first admin closer than delay
SET X1=DT
SET X2=YSASAD1
DO ^%DTC
IF X<YSASDLY
SET YSCK=-1
QUIT
+3 SET YSASIN2=YSASIN
FOR
SET YSASIN2=$ORDER(^YSTX(604,"C",DFN,YSASIN2))
if YSASIN2'>0
QUIT
Begin DoDot:1
+4 SET G2=^YSTX(604,YSASIN2,0)
SET YSASTYP2=$PIECE(G2,U,4)
SET YS2G12=$PIECE(G,U,11)
SET YSIN2=YSASIN2
+5 SET YSCK=YSASTYP2
End DoDot:1
+6 QUIT
PTLST ; list pts
+1 SET YSNM=""
FOR
SET YSNM=$ORDER(^TMP("YSAS",$JOB,"A",YSNM))
if YSNM=""
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("YSAS",$JOB,"A",YSNM,DFN))
if DFN'>0
QUIT
Begin DoDot:1
+2 SET G=^TMP("YSAS",$JOB,"A",YSNM,DFN)
SET YSCK=+G
SET YSIN1=$PIECE(G,U,2)
SET YSIN2=$PIECE(G,U,3)
+3 ; has a fU
if YSCK=3
QUIT
+4 ;admin less than delay
if YSCK=-1
QUIT
+5 DO DEM^VADPT
SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=$EXTRACT(YSNM_YSASS,1,20)_" "_$EXTRACT(VA("BID")_YSASS,1,6)_" "
+6 SET YSTOT=YSTOT+1
+7 SET G=^YSTX(604,YSIN1,0)
SET YSASCL=$PIECE(G,U,4)
SET Y=$PIECE(G,U,5)
XECUTE ^DD("DD")
+8 SET YSINTER=$PIECE(G,U,9)
if YSINTER?1N.N
SET YSINTER=$PIECE($GET(^VA(200,YSINTER,0)),U)
+9 SET ^TMP("YSAS",$JOB,"G",YSASN)=^TMP("YSAS",$JOB,"G",YSASN)_$SELECT(YSASCL=1:"Full",YSASCL=2:"Lite",YSASCL=3:"F-Up",1:" ")_" "_$EXTRACT(Y_" ",1,13)_$EXTRACT(YSINTER_YSASS,1,15)
+10 SET ^TMP("YSAS",$JOB,"G",YSASN)=^TMP("YSAS",$JOB,"G",YSASN)_" "_$SELECT(YSCK=1:" subsequent Full",YSCK=2:" subsequent Lite",1:"")
End DoDot:1
+11 QUIT
HEAD ;header
+1 KILL ^TMP("YSAS",$JOB,"G")
SET YSASS=""
SET $PIECE(YSASS," ",75)=""
+2 ;S YSASN=0,YSASITE=$P($G(^YSTX(604.8,1,0)),U) S:YSASITE'="" YSASITE=$P($G(^DIC(4,YSASITE,0)),U)
+3 SET YSASN=0
+4 SET YSASITE=$$SITE^YSASCF
+5 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=$EXTRACT(YSASS,1,15)_"Addiction Severity Index Followup Reminder"
+6 SET Y=YSASBDT\1
XECUTE ^DD("DD")
SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=" Beginning Date: "_Y
+7 SET Y=YSASEDT\1
XECUTE ^DD("DD")
SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=" Ending Date: "_Y
+8 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)="Days to Follow-up: "_YSASDLY
+9 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=" Facility: "_YSASITE
+10 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=" "
+11 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)="The following is a list of all patients who have not received followup ASI's"
+12 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)="after completed interviews between the above dates."
+13 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=$EXTRACT(YSASS,1,34)_"Last ASI Administration in Range"
+14 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)="Name"_$EXTRACT(YSASS,1,17)_"SSN Type Date Interviewer"
+15 QUIT
BOT ; bottom
+1 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=" "
+2 SET YSASN=YSASN+1
SET ^TMP("YSAS",$JOB,"G",YSASN)=YSTOT_" patients listed."
+3 QUIT
MAIL2 ; SEND MAILMAN
+1 KILL ^TMP("YSMM",$JOB)
+2 SET YSASCNT3=0
SET YSASTC=(YSASN\1000)+1
+3 SET YSASCNT=0
SET YSASCNT2=0
FOR
SET YSASCNT=$ORDER(^TMP("YSAS",$JOB,"G",YSASCNT))
if (YSASCNT'>0)
QUIT
Begin DoDot:1
+4 SET YSASCNT2=YSASCNT2+1
SET ^TMP("YSMM",$JOB,YSASCNT)=^TMP("YSAS",$JOB,"G",YSASCNT)
+5 IF (YSASCNT2=1000)!(YSASCNT=YSASN)
Begin DoDot:2
+6 SET YSASCNT3=YSASCNT3+1
+7 SET DTIME=600
+8 SET XMSUB="ASI Follow-up Reminder ("_YSASCNT3_" OF "_YSASTC_")"
+9 SET XMTEXT="^TMP(""YSMM"",$J,"
+10 SET XMY("G.ASI PERFORMANCE MEASURES")=""
+11 SET XMY(DUZ)=""
+12 SET XMDUZ="AUTOMATED MESSAGE"
+13 DO ^XMD
+14 SET YSASCNT2=0
+15 KILL ^TMP("YSMM",$JOB)
+16 SET DTIME=$$DTIME^XUP(DUZ)
End DoDot:2
End DoDot:1
+17 QUIT
