YSASSEL ;ALB/ASF-ASI SELECTOR ;4/16/98 16:42
;;5.01;MENTAL HEALTH;**24,30,38,76,121**;Dec 30, 1994;Build 61
;Reference to ^DPT( supported by DBIA #10035
;Reference to VADPT APIs supported by DBIA #10061
;Reference to %ZISC supported by IA #10089
;Reference to ^XLFDT APIs supported by DBIA #10103
;
ADDEDIT ;entry point for YSAS ADD/EDIT ASI option
N YSASPIEN
K ^TMP($J,"YSASI")
D PT
Q:YSASPIEN<1
I '$D(^YSTX(604,"C",YSASPIEN)) D ASKNEW,CLEANUP Q
W @IOF,?25,"***** Add - Edit *****"
D TLD,TLP
W !
S DIR(0)=DIR(0)_"N:NEW",DIR("A")="Select number or NEW: " D ^DIR K DIR
I Y?1N.N D Q
.S YSASSIEN=+^TMP($J,"YSASI",Y)
. I $P(^TMP($J,"YSASI",Y),U,5)=1 W !,"This ASI has already been signed. You may no longer edit it!",$C(7) Q
. D OLCL
. Q
I Y'="N" D CLEANUP Q
K DIR S DIR(0)="SA^1:Full Intake;2:Lite Intake;3:Followup ASI",DIR("A")="Select Type: ",DIR("B")="Followup" D ^DIR K DIR Q:$D(DIRUT) S YSASTYP=+Y
D AA^YSASA2(YSASPIEN,YSASTYP),OLCL,CLEANUP
Q
OLCL ;online vs clerk
D SCREENH^YSASA2
K DIR S Y=0,DIR(0)="SA^1:On-line;2:Clerk entry",DIR("A")="Select Entry option: "
S DIR("B")=$S($P(^YSTX(604.8,1,0),U,3)="C":"Clerk",1:"On-line")
D:$L(IOXY) ^DIR Q:$D(DIRUT)
L +^YSTX(604,YSASPIEN):9999 Q:'$T
D MAIN^YSASOL(YSASPIEN,YSASSIEN):Y=1,MAIN^YSASA2(YSASPIEN,YSASSIEN):Y=2
L -^YSTX(604,YSASPIEN)
Q
SELPRINT ;entry point for YSAS ASI PRINT option
N YSASPIEN
K ^TMP($J,"YSASI")
D PT
Q:YSASPIEN<1
W @IOF,?25,"***** Item Report ****"
D TLD,TLP
W !
S DIR("A")="Select ASI number: " D ^DIR K DIR W !,X," ",Y H 2
I Y?1N.N W $C(7) S YSASSIEN=+^TMP($J,"YSASI",Y) D EN1^YSASPRT(YSASSIEN)
D CLEANUP
Q
NARR ;narrative output
;entry point for YSAS NARRATIVE PRINT option
N YSASPIEN
K ^TMP($J,"YSASI")
D PT
Q:YSASPIEN<1
W @IOF,?25,"***** Narrative Report ****"
D TLD,TLP
W !
S DIR("A")="Select ASI number: " D ^DIR K DIR
Q:Y'?1N.N
S YSASSIEN=+^TMP($J,"YSASI",Y),YSASCL=$P(^YSTX(604,YSASSIEN,0),U,4)
;I YSASCL=3 W !!,"Narrative Report not available for follow ups. Please use Item Report",$C(7) Q
D EN1^YSASNAR(YSASSIEN)
D ^%ZISC
D CLEANUP
Q
ASKNEW ;
W !,"There are no previous ASI's on file.",!
S DIR("A")="Do you wish to add a new ASI for this patient"
S DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR Q:Y'=1
K DIR S DIR(0)="SA^1:Full AS1;2:Lite ASI;3:Followup ASI",DIR("A")="Select ASI Type: "
S DIR("B")=$S($P(^YSTX(604.8,1,0),U,2)="L":"Lite",1:"Full") D ^DIR K DIR Q:$D(DIRUT) S YSASTYP=+Y
I YSASTYP=3 S DIR("A")="No previous ASIs are on file for this patient. Are you sure you want to enter a FOLLOWUP",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR Q:Y'=1
D AA^YSASA2(YSASPIEN,YSASTYP),OLCL
Q
PT ;patient lookup
N DIC
S DIC="^DPT(",DIC(0)="AEMQ"
D ^DIC
S YSASPIEN=+Y
Q
TLD ;load ASI list
K ^TMP($J,"YSASI")
K DIR S DIR(0)="" ;"SA^"
S YSASIEN=0,YSASC=0
F S YSASIEN=$O(^YSTX(604,"C",YSASPIEN,YSASIEN)) Q:YSASIEN'>0 D
. S YSASC=YSASC+1
. S YSASCL=$$GET1^DIQ(604,YSASIEN_",",.04)
. S YSASDT=$$GET1^DIQ(604,YSASIEN_",",.05)
. S YSASINT=$$GET1^DIQ(604,YSASIEN_",",.09)
. S YSASIG=$$GET1^DIQ(604,YSASIEN_",",.51,"I")
. S ^TMP($J,"YSASI",YSASC)=YSASIEN_U_YSASDT_U_YSASCL_U_YSASINT_U_YSASIG
. S DIR(0)=YSASC_":"_YSASDT_";"_$P(DIR(0),";",1,20)
S DIR(0)="SA^"_DIR(0) ;
Q
TLP ; print list
Q:'$D(^TMP($J,"YSASI"))
S YSL="",$P(YSL,"_",79)=""
N DFN S DFN=YSASPIEN D DEM^VADPT
W !,VADM(1)," ""xxx-xx-",$E($P(VADM(2),U,2),8,11),?45,"Addiction Severity Index History",!
W " #",?7,"Date",?18,"Class",?30,"Interviewer",!,YSL,!
S YSASC=0
F S YSASC=$O(^TMP($J,"YSASI",YSASC)) Q:YSASC'>0 D
. S YSASG=^TMP($J,"YSASI",YSASC)
. W !,$J(YSASC,3)," "
. W $$FMTE^XLFDT($P(YSASG,U,2),"5ZD")
. W ?18,$P(YSASG,U,3)
. W ?28,$P(YSASG,U,4)
. W ?55,$S($P(YSASG,U,5)=1:"Signed",1:"## Not Signed ##")
;
Q
CLEANUP ;clean up variables
K DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
K YSASC,YSASCL,YSASDT,YSASG,YSASIEN,YSASINT,YSASIG,YSL,YSASPIEN,YSASSIEN
D KVA^VADPT
Q
BROWSE ;
D WP^DDBR(604.68,YSA_",",1,"R",YSTITLE)
Q
ASICHECK ;entry point for YSAS ASI CHECKING GUIDE option
N YSTITLE,YSA S YSTITLE="ASI CHECKING MANUAL",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
ASISHORT ;entry point for YSAS SHORT GUIDE option
N YSTITLE,YSA S YSTITLE="ASI SHORT GUIDE",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
ASIQE ;entry point for YSAS QUESTIONS AND ERRORS option
N YSTITLE,YSA S YSTITLE="COMMON QUESTIONS AND ERRORS",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
ASIHOLL ;entry point for YSAS HOLLINGSHEAD CATEGORIES option
N YSTITLE,YSA S YSTITLE="HOLLINGSHEAD CATEGORIES",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
ASIDRUG ;entry point for YSAS ASI COMMON DRUGS
N YSTITLE,YSA S YSTITLE="LIST OF COMMONLY USED DRUGS",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
ASIUSER ;entry point for YSAS USER GUIDE option
N YSTITLE,YSA S YSTITLE="ASI USER GUIDE",YSA=$O(^YSTX(604.68,"B",YSTITLE,0)) Q:YSA'>1 D BROWSE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASSEL 5049 printed Sep 23, 2025@19:49:26 Page 2
YSASSEL ;ALB/ASF-ASI SELECTOR ;4/16/98 16:42
+1 ;;5.01;MENTAL HEALTH;**24,30,38,76,121**;Dec 30, 1994;Build 61
+2 ;Reference to ^DPT( supported by DBIA #10035
+3 ;Reference to VADPT APIs supported by DBIA #10061
+4 ;Reference to %ZISC supported by IA #10089
+5 ;Reference to ^XLFDT APIs supported by DBIA #10103
+6 ;
ADDEDIT ;entry point for YSAS ADD/EDIT ASI option
+1 NEW YSASPIEN
+2 KILL ^TMP($JOB,"YSASI")
+3 DO PT
+4 if YSASPIEN<1
QUIT
+5 IF '$DATA(^YSTX(604,"C",YSASPIEN))
DO ASKNEW
DO CLEANUP
QUIT
+6 WRITE @IOF,?25,"***** Add - Edit *****"
+7 DO TLD
DO TLP
+8 WRITE !
+9 SET DIR(0)=DIR(0)_"N:NEW"
SET DIR("A")="Select number or NEW: "
DO ^DIR
KILL DIR
+10 IF Y?1N.N
Begin DoDot:1
+11 SET YSASSIEN=+^TMP($JOB,"YSASI",Y)
+12 IF $PIECE(^TMP($JOB,"YSASI",Y),U,5)=1
WRITE !,"This ASI has already been signed. You may no longer edit it!",$CHAR(7)
QUIT
+13 DO OLCL
+14 QUIT
End DoDot:1
QUIT
+15 IF Y'="N"
DO CLEANUP
QUIT
+16 KILL DIR
SET DIR(0)="SA^1:Full Intake;2:Lite Intake;3:Followup ASI"
SET DIR("A")="Select Type: "
SET DIR("B")="Followup"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET YSASTYP=+Y
+17 DO AA^YSASA2(YSASPIEN,YSASTYP)
DO OLCL
DO CLEANUP
+18 QUIT
OLCL ;online vs clerk
+1 DO SCREENH^YSASA2
+2 KILL DIR
SET Y=0
SET DIR(0)="SA^1:On-line;2:Clerk entry"
SET DIR("A")="Select Entry option: "
+3 SET DIR("B")=$SELECT($PIECE(^YSTX(604.8,1,0),U,3)="C":"Clerk",1:"On-line")
+4 if $LENGTH(IOXY)
DO ^DIR
if $DATA(DIRUT)
QUIT
+5 LOCK +^YSTX(604,YSASPIEN):9999
if '$TEST
QUIT
+6 if Y=1
DO MAIN^YSASOL(YSASPIEN,YSASSIEN)
if Y=2
DO MAIN^YSASA2(YSASPIEN,YSASSIEN)
+7 LOCK -^YSTX(604,YSASPIEN)
+8 QUIT
SELPRINT ;entry point for YSAS ASI PRINT option
+1 NEW YSASPIEN
+2 KILL ^TMP($JOB,"YSASI")
+3 DO PT
+4 if YSASPIEN<1
QUIT
+5 WRITE @IOF,?25,"***** Item Report ****"
+6 DO TLD
DO TLP
+7 WRITE !
+8 SET DIR("A")="Select ASI number: "
DO ^DIR
KILL DIR
WRITE !,X," ",Y
HANG 2
+9 IF Y?1N.N
WRITE $CHAR(7)
SET YSASSIEN=+^TMP($JOB,"YSASI",Y)
DO EN1^YSASPRT(YSASSIEN)
+10 DO CLEANUP
+11 QUIT
NARR ;narrative output
+1 ;entry point for YSAS NARRATIVE PRINT option
+2 NEW YSASPIEN
+3 KILL ^TMP($JOB,"YSASI")
+4 DO PT
+5 if YSASPIEN<1
QUIT
+6 WRITE @IOF,?25,"***** Narrative Report ****"
+7 DO TLD
DO TLP
+8 WRITE !
+9 SET DIR("A")="Select ASI number: "
DO ^DIR
KILL DIR
+10 if Y'?1N.N
QUIT
+11 SET YSASSIEN=+^TMP($JOB,"YSASI",Y)
SET YSASCL=$PIECE(^YSTX(604,YSASSIEN,0),U,4)
+12 ;I YSASCL=3 W !!,"Narrative Report not available for follow ups. Please use Item Report",$C(7) Q
+13 DO EN1^YSASNAR(YSASSIEN)
+14 DO ^%ZISC
+15 DO CLEANUP
+16 QUIT
ASKNEW ;
+1 WRITE !,"There are no previous ASI's on file.",!
+2 SET DIR("A")="Do you wish to add a new ASI for this patient"
+3 SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+4 KILL DIR
SET DIR(0)="SA^1:Full AS1;2:Lite ASI;3:Followup ASI"
SET DIR("A")="Select ASI Type: "
+5 SET DIR("B")=$SELECT($PIECE(^YSTX(604.8,1,0),U,2)="L":"Lite",1:"Full")
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET YSASTYP=+Y
+6 IF YSASTYP=3
SET DIR("A")="No previous ASIs are on file for this patient. Are you sure you want to enter a FOLLOWUP"
SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+7 DO AA^YSASA2(YSASPIEN,YSASTYP)
DO OLCL
+8 QUIT
PT ;patient lookup
+1 NEW DIC
+2 SET DIC="^DPT("
SET DIC(0)="AEMQ"
+3 DO ^DIC
+4 SET YSASPIEN=+Y
+5 QUIT
TLD ;load ASI list
+1 KILL ^TMP($JOB,"YSASI")
+2 ;"SA^"
KILL DIR
SET DIR(0)=""
+3 SET YSASIEN=0
SET YSASC=0
+4 FOR
SET YSASIEN=$ORDER(^YSTX(604,"C",YSASPIEN,YSASIEN))
if YSASIEN'>0
QUIT
Begin DoDot:1
+5 SET YSASC=YSASC+1
+6 SET YSASCL=$$GET1^DIQ(604,YSASIEN_",",.04)
+7 SET YSASDT=$$GET1^DIQ(604,YSASIEN_",",.05)
+8 SET YSASINT=$$GET1^DIQ(604,YSASIEN_",",.09)
+9 SET YSASIG=$$GET1^DIQ(604,YSASIEN_",",.51,"I")
+10 SET ^TMP($JOB,"YSASI",YSASC)=YSASIEN_U_YSASDT_U_YSASCL_U_YSASINT_U_YSASIG
+11 SET DIR(0)=YSASC_":"_YSASDT_";"_$PIECE(DIR(0),";",1,20)
End DoDot:1
+12 ;
SET DIR(0)="SA^"_DIR(0)
+13 QUIT
TLP ; print list
+1 if '$DATA(^TMP($JOB,"YSASI"))
QUIT
+2 SET YSL=""
SET $PIECE(YSL,"_",79)=""
+3 NEW DFN
SET DFN=YSASPIEN
DO DEM^VADPT
+4 WRITE !,VADM(1)," ""xxx-xx-",$EXTRACT($PIECE(VADM(2),U,2),8,11),?45,"Addiction Severity Index History",!
+5 WRITE " #",?7,"Date",?18,"Class",?30,"Interviewer",!,YSL,!
+6 SET YSASC=0
+7 FOR
SET YSASC=$ORDER(^TMP($JOB,"YSASI",YSASC))
if YSASC'>0
QUIT
Begin DoDot:1
+8 SET YSASG=^TMP($JOB,"YSASI",YSASC)
+9 WRITE !,$JUSTIFY(YSASC,3)," "
+10 WRITE $$FMTE^XLFDT($PIECE(YSASG,U,2),"5ZD")
+11 WRITE ?18,$PIECE(YSASG,U,3)
+12 WRITE ?28,$PIECE(YSASG,U,4)
+13 WRITE ?55,$SELECT($PIECE(YSASG,U,5)=1:"Signed",1:"## Not Signed ##")
End DoDot:1
+14 ;
+15 QUIT
CLEANUP ;clean up variables
+1 KILL DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+2 KILL YSASC,YSASCL,YSASDT,YSASG,YSASIEN,YSASINT,YSASIG,YSL,YSASPIEN,YSASSIEN
+3 DO KVA^VADPT
+4 QUIT
BROWSE ;
+1 DO WP^DDBR(604.68,YSA_",",1,"R",YSTITLE)
+2 QUIT
ASICHECK ;entry point for YSAS ASI CHECKING GUIDE option
+1 NEW YSTITLE,YSA
SET YSTITLE="ASI CHECKING MANUAL"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
ASISHORT ;entry point for YSAS SHORT GUIDE option
+1 NEW YSTITLE,YSA
SET YSTITLE="ASI SHORT GUIDE"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
ASIQE ;entry point for YSAS QUESTIONS AND ERRORS option
+1 NEW YSTITLE,YSA
SET YSTITLE="COMMON QUESTIONS AND ERRORS"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
ASIHOLL ;entry point for YSAS HOLLINGSHEAD CATEGORIES option
+1 NEW YSTITLE,YSA
SET YSTITLE="HOLLINGSHEAD CATEGORIES"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
ASIDRUG ;entry point for YSAS ASI COMMON DRUGS
+1 NEW YSTITLE,YSA
SET YSTITLE="LIST OF COMMONLY USED DRUGS"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
ASIUSER ;entry point for YSAS USER GUIDE option
+1 NEW YSTITLE,YSA
SET YSTITLE="ASI USER GUIDE"
SET YSA=$ORDER(^YSTX(604.68,"B",YSTITLE,0))
if YSA'>1
QUIT
DO BROWSE
+2 QUIT
