YSASOL ;ASF/ALB,HIOFO/FT - ASI ON-LINE ENTRY ;1/31/13 10:49am
;;5.01;MENTAL HEALTH;**24,30,32,38,121**;Dec 30, 1994;Build 61
;Reference to ^VA(200, supported by DBIA #10060
;Reference to VADPT supported by IA #10061
MAIN(YSASPIEN,YSASSIEN) ;
Q:$G(YSASSIEN)'>0
Q:$G(YSASPIEN)'>0
D SCREENH^YSASA2
S YSASLL="",$P(YSASLL,"_",79)="" ;ASF 5/22
S YSIENS=YSASSIEN_","
S YSASTYP=$$GET1^DIQ(604,YSIENS,"CLASS")
S YSGP=$S(YSASTYP?1"L".E:5,YSASTYP?1"FO".E:6,1:4)
S DFN=YSASPIEN D DEM^VADPT S YSHDR1=VADM(1)_" "_"xxx-xx-"_$E($P(VADM(2),U,2),8,11) D KVAR^VADPT
S YSFILE=604,YSFLAG="EF",YSBACK=1 ;ASF 5/16
S YSFDA="^TMP($J,""YSASI"")"
K ^TMP($J,"YSASI")
S YSDFLAG=$$GET1^DIQ(604.8,"1,",.04)
S YSEFLAG=$$GET1^DIQ(604.8,"1,",.07)
S YSN=0,YSV=""
LOOP ;
F S YSN=$O(^YSTX(604.66,YSN)) Q:YSN'>0!(YSV="^") S YSENDLP=0 D L3
D HEAD
D FILE^DIE("K","^TMP($J,""YSASI"")")
WP ;
K DIRUT,DIR F Q:$D(DIRUT) D
. W !!?10,"*** Additional Areas ***",!,"1. Spiritual",!,"2. Leisure",!
. S DIR("A")="Enter Comment for? ",DIR(0)="SAO^1:Spiritual;2:Leisure" D ^DIR
. Q:$D(DIRUT)
. S DR=$S(Y=1:188,Y=2:187,1:"")
. S DA=YSASSIEN,DIE="^YSTX(604,"
. D ^DIE
. Q
;
D EN^YSASSN(YSASSIEN)
Q
L3 ;
S YSG=^YSTX(604.66,YSN,0),YSFIELD=+$P(YSG,U,3),YSQ=$P(YSG,U,2),YSDEF=$P(YSG,U,7),YSASENT=$P(YSG,U,9),YSASID=$P(YSG,U,11)
S YSASEX=$G(^YSTX(604.66,YSN,1))
Q:$P(YSG,U,YSGP)=""
;
Q:YSENDLP ;quit if executable sets flag
;
L4 ;No form feed
D FDAGET S YSP=Y
S:YSP=""!(YSP="^") YSP=$$GET1^DIQ(604,YSIENS,YSFIELD)
I YSP="",YSDFLAG="YES" S YSP=YSDEF ; SET DEFAULT IF FLAG SET
D DISP ;W !,YSQ,$S(YSP="":": ",1:": "_YSP_" // ")
L5 R YSV:DTIME S:'$T YSV="^"
S:YSV="" YSV=YSP
Q:YSV=""!(YSV="^")
I YSV?1"^"1A1N.E D Q:YSNN1'=0
. I YSV?1"^"1L.N S YSV="^"_$C($A(YSV,2)-32)_$E(YSV,3,9)
. S (YSNN,YSNN1)=0,YSBACK=YSN-.01 ;ASF 5/16
. S YSNN=$O(^YSTX(604.66,"C",$E(YSV,2,9)))
. Q:$E(YSNN,1,$L(YSV)-1)'=$E(YSV,2,9)
. S:$L(YSNN) YSNN1=$O(^YSTX(604.66,"C",YSNN,-1))
. S:YSNN1 YSN=YSNN1-.01
;
I YSV="^b"!(YSV="^B") S:$D(YSBACK) YSN=YSBACK Q ;ASF 5/16
I YSV="?" D DISPQ G L4
I YSV?1"??"."?" D G L5
.I YSFIELD'=.09,YSFIELD'=2,YSFIELD'=9.14,YSFIELD'=10.45,YSFIELD'=14.26,YSFIELD'=14.28 W $C(7)," No extended help available " Q
. I YSFIELD=2 D HEAD D D ANS
.. S DIC="^YSTX(604.26,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
. I YSFIELD=10.45 D HEAD D D ANS
.. S DIC="^YSTX(604.77,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
. I YSFIELD=14.26!(YSFIELD=14.28) D HEAD D D ANS
.. S DIC="^YSTX(604.3,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
. I YSFIELD=9.14 D HEAD D D ANS
.. S Y=0 F S Y=$O(^YSTX(604.68,3,1,Y)) Q:Y'>0 W !,^(Y,0)
. I YSFIELD=.09 D HEAD D
.. S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select Interviewer: "
.. D ^DIC S YSP=$S(+Y>0:$P(Y,U,2),1:"????") K DIC D ANS ;ASF 5/16
. Q
I YSV?1"^C".E!(YSV?1"^c".E) D G L4
. S DIE="^YSTX(604,",DA=YSASSIEN
. S DR=$S(YSASID?1"G".E:.6,YSASID?1"M".E:8.5,YSASID?1"E".E:9.5,YSASID?1"D".E:10.5,YSASID?1"L".E:14.5,YSASID?1"H".E:16.5,YSASID?1"F".E:18.5,YSASID?1"P".E:19.5,1:"")
. I DR D
.. D HEAD
. D ^DIE
;
S:YSV?1N.N YSV=+YSV ;ASF 5/16/97
D VAL
I YSA="^" W $C(7),"?? " G L5
W ?$X+3,YSA(0)
I YSEFLAG="YES" X YSASEX ; branch if parameters allowed
Q
VAL ;
D VAL^DIE(YSFILE,YSIENS,YSFIELD,YSFLAG,YSV,.YSA,YSFDA,"^TMP($J,""YSASERR"")")
Q
TEST ;
D MAIN(1,30)
Q
FDAGET ;
S Y=$$VALUE1^DILF(YSFILE,YSFIELD,YSFDA)
S:Y'=""&(Y'="^") Y=$$EXTERNAL^DILFD(YSFILE,YSFIELD,"",Y)
Q
DISP ;display question
D HEAD
W ?15,YSASRV1,YSASID,YSASRV0," "
W $S(YSASID?1"G".E:"General Information",YSASID?1"M".E:"Medical Status",YSASID?1"E".E:"Employment Status",YSASID?1"D".E:"Drug/Alcohol Status",YSASID?1"L".E:"Legal Status",1:"")
W $S(YSASID?1"P".E:"Psychiatric Status",YSASID?1"H".E:"Family History",YSASID?1"F".E:"Family/Social Relationships",1:"")
HINT ;
S DX=0,DY=20 X IOXY W YSASLL ;ASF 5/22
W !,$G(^YSTX(604.66,YSN,3,1,0)),!,$G(^YSTX(604.66,YSN,3,2,0))
W !,$E($G(^YSTX(604.66,YSN,3,3,0)),1,50),?62,YSASRV1,"Enter ? for help",YSASRV0
S DX=0,DY=3 X IOXY
W YSASRV1 S J=0 F S J=$O(^YSTX(604.66,YSN,2,J)) Q:J'>0 W !,$S(J=1&($P(^YSTX(604.66,YSN,0),U,10)=1)&(YSASTYP="FOLLOWUP"):"* ",1:""),^YSTX(604.66,YSN,2,J,0)
W YSASRV0
I YSFIELD>3,YSFIELD'=10.45,YSFIELD'=14.26,YSFIELD'=14.28,$P(^DD(604,YSFIELD,0),U,2)?.E1"P".E D
. S YSATRIB=$P(^DD(604,YSFIELD,0),U,3) ;$$GET1^DID(YSFILE,YSFIELD,"","POINTER")
. S DIC="^"_YSATRIB,DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
E I YSFIELD'=9.14 W ! D HELP^DIE(604,"",YSFIELD,"?"),MSG^DIALOG("HW") W !
I YSFIELD=9.14 W !!!,^DD(604,YSFIELD,3),!
;
ANS W:$Y<10 !
W !,YSASID_" Answer",$S(YSP="":": ",1:": "_YSP_" // ")
Q
DISPQ ;
D HEAD
D EN^DDIOL("","^YSTX(604.68,21,1)")
S DX=0,DY=22 X IOXY K DIR S DIR(0)="E" D ^DIR
Q
HEAD ;
W @IOF,IOHOME,IOEDEOP
W YSHDR1,?45,"Addiction Severity Index ",YSASRV1,YSASTYP,YSASRV0,!
W YSASLL,! ;ASF 5/22
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASOL 5042 printed Dec 13, 2024@02:13:14 Page 2
YSASOL ;ASF/ALB,HIOFO/FT - ASI ON-LINE ENTRY ;1/31/13 10:49am
+1 ;;5.01;MENTAL HEALTH;**24,30,32,38,121**;Dec 30, 1994;Build 61
+2 ;Reference to ^VA(200, supported by DBIA #10060
+3 ;Reference to VADPT supported by IA #10061
MAIN(YSASPIEN,YSASSIEN) ;
+1 if $GET(YSASSIEN)'>0
QUIT
+2 if $GET(YSASPIEN)'>0
QUIT
+3 DO SCREENH^YSASA2
+4 ;ASF 5/22
SET YSASLL=""
SET $PIECE(YSASLL,"_",79)=""
+5 SET YSIENS=YSASSIEN_","
+6 SET YSASTYP=$$GET1^DIQ(604,YSIENS,"CLASS")
+7 SET YSGP=$SELECT(YSASTYP?1"L".E:5,YSASTYP?1"FO".E:6,1:4)
+8 SET DFN=YSASPIEN
DO DEM^VADPT
SET YSHDR1=VADM(1)_" "_"xxx-xx-"_$EXTRACT($PIECE(VADM(2),U,2),8,11)
DO KVAR^VADPT
+9 ;ASF 5/16
SET YSFILE=604
SET YSFLAG="EF"
SET YSBACK=1
+10 SET YSFDA="^TMP($J,""YSASI"")"
+11 KILL ^TMP($JOB,"YSASI")
+12 SET YSDFLAG=$$GET1^DIQ(604.8,"1,",.04)
+13 SET YSEFLAG=$$GET1^DIQ(604.8,"1,",.07)
+14 SET YSN=0
SET YSV=""
LOOP ;
+1 FOR
SET YSN=$ORDER(^YSTX(604.66,YSN))
if YSN'>0!(YSV="^")
QUIT
SET YSENDLP=0
DO L3
+2 DO HEAD
+3 DO FILE^DIE("K","^TMP($J,""YSASI"")")
WP ;
+1 KILL DIRUT,DIR
FOR
if $DATA(DIRUT)
QUIT
Begin DoDot:1
+2 WRITE !!?10,"*** Additional Areas ***",!,"1. Spiritual",!,"2. Leisure",!
+3 SET DIR("A")="Enter Comment for? "
SET DIR(0)="SAO^1:Spiritual;2:Leisure"
DO ^DIR
+4 if $DATA(DIRUT)
QUIT
+5 SET DR=$SELECT(Y=1:188,Y=2:187,1:"")
+6 SET DA=YSASSIEN
SET DIE="^YSTX(604,"
+7 DO ^DIE
+8 QUIT
End DoDot:1
+9 ;
+10 DO EN^YSASSN(YSASSIEN)
+11 QUIT
L3 ;
+1 SET YSG=^YSTX(604.66,YSN,0)
SET YSFIELD=+$PIECE(YSG,U,3)
SET YSQ=$PIECE(YSG,U,2)
SET YSDEF=$PIECE(YSG,U,7)
SET YSASENT=$PIECE(YSG,U,9)
SET YSASID=$PIECE(YSG,U,11)
+2 SET YSASEX=$GET(^YSTX(604.66,YSN,1))
+3 if $PIECE(YSG,U,YSGP)=""
QUIT
+4 ;
+5 ;quit if executable sets flag
if YSENDLP
QUIT
+6 ;
L4 ;No form feed
+1 DO FDAGET
SET YSP=Y
+2 if YSP=""!(YSP="^")
SET YSP=$$GET1^DIQ(604,YSIENS,YSFIELD)
+3 ; SET DEFAULT IF FLAG SET
IF YSP=""
IF YSDFLAG="YES"
SET YSP=YSDEF
+4 ;W !,YSQ,$S(YSP="":": ",1:": "_YSP_" // ")
DO DISP
L5 READ YSV:DTIME
if '$TEST
SET YSV="^"
+1 if YSV=""
SET YSV=YSP
+2 if YSV=""!(YSV="^")
QUIT
+3 IF YSV?1"^"1A1N.E
Begin DoDot:1
+4 IF YSV?1"^"1L.N
SET YSV="^"_$CHAR($ASCII(YSV,2)-32)_$EXTRACT(YSV,3,9)
+5 ;ASF 5/16
SET (YSNN,YSNN1)=0
SET YSBACK=YSN-.01
+6 SET YSNN=$ORDER(^YSTX(604.66,"C",$EXTRACT(YSV,2,9)))
+7 if $EXTRACT(YSNN,1,$LENGTH(YSV)-1)'=$EXTRACT(YSV,2,9)
QUIT
+8 if $LENGTH(YSNN)
SET YSNN1=$ORDER(^YSTX(604.66,"C",YSNN,-1))
+9 if YSNN1
SET YSN=YSNN1-.01
End DoDot:1
if YSNN1'=0
QUIT
+10 ;
+11 ;ASF 5/16
IF YSV="^b"!(YSV="^B")
if $DATA(YSBACK)
SET YSN=YSBACK
QUIT
+12 IF YSV="?"
DO DISPQ
GOTO L4
+13 IF YSV?1"??"."?"
Begin DoDot:1
+14 IF YSFIELD'=.09
IF YSFIELD'=2
IF YSFIELD'=9.14
IF YSFIELD'=10.45
IF YSFIELD'=14.26
IF YSFIELD'=14.28
WRITE $CHAR(7)," No extended help available "
QUIT
+15 IF YSFIELD=2
DO HEAD
Begin DoDot:2
+16 SET DIC="^YSTX(604.26,"
SET DIC(0)="FIS"
SET D="B"
SET DZ="??"
DO DQ^DICQ
KILL DIC,DIE,DID,D,DIX,DO
End DoDot:2
DO ANS
+17 IF YSFIELD=10.45
DO HEAD
Begin DoDot:2
+18 SET DIC="^YSTX(604.77,"
SET DIC(0)="FIS"
SET D="B"
SET DZ="??"
DO DQ^DICQ
KILL DIC,DIE,DID,D,DIX,DO
End DoDot:2
DO ANS
+19 IF YSFIELD=14.26!(YSFIELD=14.28)
DO HEAD
Begin DoDot:2
+20 SET DIC="^YSTX(604.3,"
SET DIC(0)="FIS"
SET D="B"
SET DZ="??"
DO DQ^DICQ
KILL DIC,DIE,DID,D,DIX,DO
End DoDot:2
DO ANS
+21 IF YSFIELD=9.14
DO HEAD
Begin DoDot:2
+22 SET Y=0
FOR
SET Y=$ORDER(^YSTX(604.68,3,1,Y))
if Y'>0
QUIT
WRITE !,^(Y,0)
End DoDot:2
DO ANS
+23 IF YSFIELD=.09
DO HEAD
Begin DoDot:2
+24 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")="Select Interviewer: "
+25 ;ASF 5/16
DO ^DIC
SET YSP=$SELECT(+Y>0:$PIECE(Y,U,2),1:"????")
KILL DIC
DO ANS
End DoDot:2
+26 QUIT
End DoDot:1
GOTO L5
+27 IF YSV?1"^C".E!(YSV?1"^c".E)
Begin DoDot:1
+28 SET DIE="^YSTX(604,"
SET DA=YSASSIEN
+29 SET DR=$SELECT(YSASID?1"G".E:.6,YSASID?1"M".E:8.5,YSASID?1"E".E:9.5,YSASID?1"D".E:10.5,YSASID?1"L".E:14.5,YSASID?1"H".E:16.5,YSASID?1"F".E:18.5,YSASID?1"P".E:19.5,1:"")
+30 IF DR
Begin DoDot:2
+31 DO HEAD
End DoDot:2
+32 DO ^DIE
End DoDot:1
GOTO L4
+33 ;
+34 ;ASF 5/16/97
if YSV?1N.N
SET YSV=+YSV
+35 DO VAL
+36 IF YSA="^"
WRITE $CHAR(7),"?? "
GOTO L5
+37 WRITE ?$X+3,YSA(0)
+38 ; branch if parameters allowed
IF YSEFLAG="YES"
XECUTE YSASEX
+39 QUIT
VAL ;
+1 DO VAL^DIE(YSFILE,YSIENS,YSFIELD,YSFLAG,YSV,.YSA,YSFDA,"^TMP($J,""YSASERR"")")
+2 QUIT
TEST ;
+1 DO MAIN(1,30)
+2 QUIT
FDAGET ;
+1 SET Y=$$VALUE1^DILF(YSFILE,YSFIELD,YSFDA)
+2 if Y'=""&(Y'="^")
SET Y=$$EXTERNAL^DILFD(YSFILE,YSFIELD,"",Y)
+3 QUIT
DISP ;display question
+1 DO HEAD
+2 WRITE ?15,YSASRV1,YSASID,YSASRV0," "
+3 WRITE $SELECT(YSASID?1"G".E:"General Information",YSASID?1"M".E:"Medical Status",YSASID?1"E".E:"Employment Status",YSASID?1"D".E:"Drug/Alcohol Status",YSASID?1"L".E:"Legal Status",1:"")
+4 WRITE $SELECT(YSASID?1"P".E:"Psychiatric Status",YSASID?1"H".E:"Family History",YSASID?1"F".E:"Family/Social Relationships",1:"")
HINT ;
+1 ;ASF 5/22
SET DX=0
SET DY=20
XECUTE IOXY
WRITE YSASLL
+2 WRITE !,$GET(^YSTX(604.66,YSN,3,1,0)),!,$GET(^YSTX(604.66,YSN,3,2,0))
+3 WRITE !,$EXTRACT($GET(^YSTX(604.66,YSN,3,3,0)),1,50),?62,YSASRV1,"Enter ? for help",YSASRV0
+4 SET DX=0
SET DY=3
XECUTE IOXY
+5 WRITE YSASRV1
SET J=0
FOR
SET J=$ORDER(^YSTX(604.66,YSN,2,J))
if J'>0
QUIT
WRITE !,$SELECT(J=1&($PIECE(^YSTX(604.66,YSN,0),U,10)=1)&(YSASTYP="FOLLOWUP"):"* ",1:""),^YSTX(604.66,YSN,2,J,0)
+6 WRITE YSASRV0
+7 IF YSFIELD>3
IF YSFIELD'=10.45
IF YSFIELD'=14.26
IF YSFIELD'=14.28
IF $PIECE(^DD(604,YSFIELD,0),U,2)?.E1"P".E
Begin DoDot:1
+8 ;$$GET1^DID(YSFILE,YSFIELD,"","POINTER")
SET YSATRIB=$PIECE(^DD(604,YSFIELD,0),U,3)
+9 SET DIC="^"_YSATRIB
SET DIC(0)="FIS"
SET D="B"
SET DZ="??"
DO DQ^DICQ
KILL DIC,DIE,DID,D,DIX,DO
End DoDot:1
+10 IF '$TEST
IF YSFIELD'=9.14
WRITE !
DO HELP^DIE(604,"",YSFIELD,"?")
DO MSG^DIALOG("HW")
WRITE !
+11 IF YSFIELD=9.14
WRITE !!!,^DD(604,YSFIELD,3),!
+12 ;
ANS if $Y<10
WRITE !
+1 WRITE !,YSASID_" Answer",$SELECT(YSP="":": ",1:": "_YSP_" // ")
+2 QUIT
DISPQ ;
+1 DO HEAD
+2 DO EN^DDIOL("","^YSTX(604.68,21,1)")
+3 SET DX=0
SET DY=22
XECUTE IOXY
KILL DIR
SET DIR(0)="E"
DO ^DIR
+4 QUIT
HEAD ;
+1 WRITE @IOF,IOHOME,IOEDEOP
+2 WRITE YSHDR1,?45,"Addiction Severity Index ",YSASRV1,YSASTYP,YSASRV0,!
+3 ;ASF 5/22
WRITE YSASLL,!
+4 QUIT
