YSASLIB ;692/DCL-ASI,HIOFO/FT - LIBRARY FUNCTIONS ;2/21/13 10:38am
;;5.01;MENTAL HEALTH;**24,37,121**;Dec 30, 1994;Build 61
;Reference to ^DPT supported by IA #10035
;Reference to ^%ZISS supported by DBIA #10088
;Reference to ^XLFDT APIs supported by DBIA #10103
Q
;
ID(YSAS) ;Identifiers for file 604, pass Y (IEN)
Q:$G(YSAS)'>0 ""
N YSASN,YSASD,YSAST,YSAS0,DIERR
S YSAS0=^YSTX(604,YSAS,0),YSASN=$P(YSAS0,"^",2)
S:YSASN>0 YSASN=$P(^DPT(YSASN,0),"^")
S YSASD=$$FMTE^XLFDT($P(YSAS0,U,5),"5ZD")
S YSAST=$$GET1^DIQ(604,YSAS_",",.04)
Q $J("",(10-$L(YSAS)))_YSASN_$J("",(30-$L(YSASN)))_$J(YSASD,10)_" "_YSAST
;
FUID(YSAS) ;Identifiers for file 604, pass Y (IEN) used when listing FOLLOW-UP ASI.
Q:$G(YSAS)'>0 ""
N YSASN,YSASD,YSASF,YSASFN,YSAS0,DIERR,YSASP
S YSAS0=^YSTX(604,YSAS,0),YSASN=$P(YSAS0,"^",2)
S:YSASN>0 YSASN=$P(^DPT(YSASN,0),"^")
S YSASD=$P($P($G(^YSTX(604,YSAS,11)),"^",10),"@")
S YSASF=$P($G(^YSTX(604,YSAS,12)),"^",3),YSASP=$P(^(12),"^",2)
S YSASFN=$S(YSASF>0:$P($G(^YSTX(604.5,YSASF,0)),"^"),1:"")
Q $J("",(10-$L(YSAS)))_YSASN_$J("",(30-$L(YSASN)))_$J(YSASD,8)_$J(YSASP,9)_" "_YSASFN
;
PID(YSAS) ;Identifiers for Patient file, #2 - pass Y (IEN)
Q:$G(YSAS)'>0
N YSASDOB,YSASSSN,YSAS0
S YSAS0=^DPT(YSAS,0),YSASDOB=$$DT($P(YSAS0,"^",3))
S YSASSSN=$$SSN($P(YSAS0,"^",9)),YSASN=$P(YSAS0,"^")
Q $J("",(30-$L(YSASN)))_" "_$J(YSASDOB,8)_" "_$J(YSASSSN,12)
;
DT(X) ;Convert date to external format
Q:$G(X)="" ""
Q $$FMTE^XLFDT(X,"5ZD")
;
SSN(X) ;Convert ssn to external format
Q:$G(X)="" ""
Q $E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
;
NEW() ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
N AUI2X
F AUI2X=$P(^YSTX(604,0),U,3):1 I '$D(^YSTX(604,AUI2X)) L +^YSTX(604,AUI2X):DILOCKTM Q:$T
Q AUI2X
;
NEW047(D0) ;Adding new sub-entry and return an internal number - EXTRINSIC
Q:'$G(D0) ""
Q:'$P(^YSTX(604,D0,.047,0),"^",3) 1
N YSASX
F YSASX=$P(^YSTX(604,D0,.047,0),"^",3):1 I '$D(^YSTX(604,D0,.047,YSASX)) L +^YSTX(604,D0,.047,YSASX):DILOCKTM Q:$T
Q YSASX
;
VL() ;
I '$D(IOVL) D GSET^%ZISS
Q IOG1_IOVL_IOG0
;
X(X,F,T) ;Check is X is integer or NN or XX and return truth value TO KILL X (INPUT TRANSFORM)
;Pass From To value for integers ie 0,9, 1,99 or 1,9999.
I X?1N.N,$G(F)]"",$G(T)]"",X'<F,X'>T Q 0
I X="NN" Q 0
I X="XX" Q 0
I X="X" Q 0
Q 1
;
USI(YSADUZ) ;Unsigned Intakes, pass user's duz and return total number of unsigned intakes
Q:$G(YSADUZ)'>0 ""
N C,D,X
S (C,X)=0,D="A.81."_YSADUZ
F S X=$O(^YSTX(604,D,X)) Q:X'>0 I $P(^YSTX(604,X,0),"^",4)=1 S C=C+1
Q C
;
USF(YSADUZ) ;Unsigned Follow-ups, pass user's duz and return total number on unsigned follow-ups
Q:$G(YSADUZ)'>0 ""
N C,D,X
S (C,X)=0,D="A.81."_YSADUZ
F S X=$O(^YSTX(604,D,X)) Q:X'>0 I $P(^YSTX(604,X,0),"^",4)=2 S C=C+1
Q C
;
US(YSADUZ) ;Unsigned ASIs return in 2 piece string #INTAKEs^#FOLLOW-UPs
Q:$G(YSADUZ)'>0 ""
N C,C1,C2,C3,D,X
S (C1,C2,C3,X)=0,D="A.81."_YSADUZ
F S X=$O(^YSTX(604,D,X)) Q:X'>0 D
.S C=$P(^YSTX(604,X,0),"^",4)
.Q:C'>0
.I C=1 S C1=C1+1 Q
.I C=2 S C2=C2+1 Q
.I C=3 S C3=C3+1 Q
.Q
Q C1_"^"_C2_"^"_C3
;
DISP(YSADUZ,YSASCLS) ;Display ASI requiring signature - pass DUZ and CLASS (ASI TYPE)
Q:$G(YSADUZ)'>0
Q:$G(YSASCLS)'>0
N C,C1,C2,D,X,X0,X11
S (C1,C2,X)=0,D="A.81."_YSADUZ
W !
F S X=$O(^YSTX(604,D,X)) Q:X'>0 D
.S X0=^YSTX(604,X,0),X11=$G(^(11)),C=$P(X0,"^",4)
.Q:C'>0
.Q:C'=YSASCLS
.W !?4,X,?14,$P(^DPT($P(X0,"^",2),0),"^"),?46,$P(X11,"^",10)
.Q
W !
Q
INTRO ;
W:$D(IOF) @IOF
W !?20,"ADDICTION SEVERITY INDEX",!?25,"FIFTH EDITION",!!
D STATUS()
Q
STATUS(YSAU) ;Return status of unsigned ASIs on a user.
S:$G(YSAU)'>0 YSAU=DUZ
N YSAS,X
S YSAS=$$US(YSAU)
F I=1:1:3 S X=$P(YSAS,U,I) D:X
.W !,"You have ",$J(X,3)," unsigned ASI ",$S(I=2:"Lite",I=3:"Followup",1:"Full Intake"),$S(X>1:"s",1:""),"."
.Q
Q
RACE(X) ;Pass file 2 race code and return ASI race code, if possible.
Q:$G(X)'>0 ""
I X=1 Q 2
I X=3 Q 1
I X=5 Q 5
Q ""
;
REL(X) ;Pass file 2 religion code and return ASI religion code, if possible.
Q:$G(X)'>0 ""
I X=1 Q 3
I X=20 Q 4
I X=22 Q 5
I X=99 Q 2
Q ""
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASLIB 4224 printed Sep 23, 2025@19:49:15 Page 2
YSASLIB ;692/DCL-ASI,HIOFO/FT - LIBRARY FUNCTIONS ;2/21/13 10:38am
+1 ;;5.01;MENTAL HEALTH;**24,37,121**;Dec 30, 1994;Build 61
+2 ;Reference to ^DPT supported by IA #10035
+3 ;Reference to ^%ZISS supported by DBIA #10088
+4 ;Reference to ^XLFDT APIs supported by DBIA #10103
+5 QUIT
+6 ;
ID(YSAS) ;Identifiers for file 604, pass Y (IEN)
+1 if $GET(YSAS)'>0
QUIT ""
+2 NEW YSASN,YSASD,YSAST,YSAS0,DIERR
+3 SET YSAS0=^YSTX(604,YSAS,0)
SET YSASN=$PIECE(YSAS0,"^",2)
+4 if YSASN>0
SET YSASN=$PIECE(^DPT(YSASN,0),"^")
+5 SET YSASD=$$FMTE^XLFDT($PIECE(YSAS0,U,5),"5ZD")
+6 SET YSAST=$$GET1^DIQ(604,YSAS_",",.04)
+7 QUIT $JUSTIFY("",(10-$LENGTH(YSAS)))_YSASN_$JUSTIFY("",(30-$LENGTH(YSASN)))_$JUSTIFY(YSASD,10)_" "_YSAST
+8 ;
FUID(YSAS) ;Identifiers for file 604, pass Y (IEN) used when listing FOLLOW-UP ASI.
+1 if $GET(YSAS)'>0
QUIT ""
+2 NEW YSASN,YSASD,YSASF,YSASFN,YSAS0,DIERR,YSASP
+3 SET YSAS0=^YSTX(604,YSAS,0)
SET YSASN=$PIECE(YSAS0,"^",2)
+4 if YSASN>0
SET YSASN=$PIECE(^DPT(YSASN,0),"^")
+5 SET YSASD=$PIECE($PIECE($GET(^YSTX(604,YSAS,11)),"^",10),"@")
+6 SET YSASF=$PIECE($GET(^YSTX(604,YSAS,12)),"^",3)
SET YSASP=$PIECE(^(12),"^",2)
+7 SET YSASFN=$SELECT(YSASF>0:$PIECE($GET(^YSTX(604.5,YSASF,0)),"^"),1:"")
+8 QUIT $JUSTIFY("",(10-$LENGTH(YSAS)))_YSASN_$JUSTIFY("",(30-$LENGTH(YSASN)))_$JUSTIFY(YSASD,8)_$JUSTIFY(YSASP,9)_" "_YSASFN
+9 ;
PID(YSAS) ;Identifiers for Patient file, #2 - pass Y (IEN)
+1 if $GET(YSAS)'>0
QUIT
+2 NEW YSASDOB,YSASSSN,YSAS0
+3 SET YSAS0=^DPT(YSAS,0)
SET YSASDOB=$$DT($PIECE(YSAS0,"^",3))
+4 SET YSASSSN=$$SSN($PIECE(YSAS0,"^",9))
SET YSASN=$PIECE(YSAS0,"^")
+5 QUIT $JUSTIFY("",(30-$LENGTH(YSASN)))_" "_$JUSTIFY(YSASDOB,8)_" "_$JUSTIFY(YSASSSN,12)
+6 ;
DT(X) ;Convert date to external format
+1 if $GET(X)=""
QUIT ""
+2 QUIT $$FMTE^XLFDT(X,"5ZD")
+3 ;
SSN(X) ;Convert ssn to external format
+1 if $GET(X)=""
QUIT ""
+2 QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,9)
+3 ;
NEW() ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
+1 NEW AUI2X
+2 FOR AUI2X=$PIECE(^YSTX(604,0),U,3):1
IF '$DATA(^YSTX(604,AUI2X))
LOCK +^YSTX(604,AUI2X):DILOCKTM
if $TEST
QUIT
+3 QUIT AUI2X
+4 ;
NEW047(D0) ;Adding new sub-entry and return an internal number - EXTRINSIC
+1 if '$GET(D0)
QUIT ""
+2 if '$PIECE(^YSTX(604,D0,.047,0),"^",3)
QUIT 1
+3 NEW YSASX
+4 FOR YSASX=$PIECE(^YSTX(604,D0,.047,0),"^",3):1
IF '$DATA(^YSTX(604,D0,.047,YSASX))
LOCK +^YSTX(604,D0,.047,YSASX):DILOCKTM
if $TEST
QUIT
+5 QUIT YSASX
+6 ;
VL() ;
+1 IF '$DATA(IOVL)
DO GSET^%ZISS
+2 QUIT IOG1_IOVL_IOG0
+3 ;
X(X,F,T) ;Check is X is integer or NN or XX and return truth value TO KILL X (INPUT TRANSFORM)
+1 ;Pass From To value for integers ie 0,9, 1,99 or 1,9999.
+2 IF X?1N.N
IF $GET(F)]""
IF $GET(T)]""
IF X'<F
IF X'>T
QUIT 0
+3 IF X="NN"
QUIT 0
+4 IF X="XX"
QUIT 0
+5 IF X="X"
QUIT 0
+6 QUIT 1
+7 ;
USI(YSADUZ) ;Unsigned Intakes, pass user's duz and return total number of unsigned intakes
+1 if $GET(YSADUZ)'>0
QUIT ""
+2 NEW C,D,X
+3 SET (C,X)=0
SET D="A.81."_YSADUZ
+4 FOR
SET X=$ORDER(^YSTX(604,D,X))
if X'>0
QUIT
IF $PIECE(^YSTX(604,X,0),"^",4)=1
SET C=C+1
+5 QUIT C
+6 ;
USF(YSADUZ) ;Unsigned Follow-ups, pass user's duz and return total number on unsigned follow-ups
+1 if $GET(YSADUZ)'>0
QUIT ""
+2 NEW C,D,X
+3 SET (C,X)=0
SET D="A.81."_YSADUZ
+4 FOR
SET X=$ORDER(^YSTX(604,D,X))
if X'>0
QUIT
IF $PIECE(^YSTX(604,X,0),"^",4)=2
SET C=C+1
+5 QUIT C
+6 ;
US(YSADUZ) ;Unsigned ASIs return in 2 piece string #INTAKEs^#FOLLOW-UPs
+1 if $GET(YSADUZ)'>0
QUIT ""
+2 NEW C,C1,C2,C3,D,X
+3 SET (C1,C2,C3,X)=0
SET D="A.81."_YSADUZ
+4 FOR
SET X=$ORDER(^YSTX(604,D,X))
if X'>0
QUIT
Begin DoDot:1
+5 SET C=$PIECE(^YSTX(604,X,0),"^",4)
+6 if C'>0
QUIT
+7 IF C=1
SET C1=C1+1
QUIT
+8 IF C=2
SET C2=C2+1
QUIT
+9 IF C=3
SET C3=C3+1
QUIT
+10 QUIT
End DoDot:1
+11 QUIT C1_"^"_C2_"^"_C3
+12 ;
DISP(YSADUZ,YSASCLS) ;Display ASI requiring signature - pass DUZ and CLASS (ASI TYPE)
+1 if $GET(YSADUZ)'>0
QUIT
+2 if $GET(YSASCLS)'>0
QUIT
+3 NEW C,C1,C2,D,X,X0,X11
+4 SET (C1,C2,X)=0
SET D="A.81."_YSADUZ
+5 WRITE !
+6 FOR
SET X=$ORDER(^YSTX(604,D,X))
if X'>0
QUIT
Begin DoDot:1
+7 SET X0=^YSTX(604,X,0)
SET X11=$GET(^(11))
SET C=$PIECE(X0,"^",4)
+8 if C'>0
QUIT
+9 if C'=YSASCLS
QUIT
+10 WRITE !?4,X,?14,$PIECE(^DPT($PIECE(X0,"^",2),0),"^"),?46,$PIECE(X11,"^",10)
+11 QUIT
End DoDot:1
+12 WRITE !
+13 QUIT
INTRO ;
+1 if $DATA(IOF)
WRITE @IOF
+2 WRITE !?20,"ADDICTION SEVERITY INDEX",!?25,"FIFTH EDITION",!!
+3 DO STATUS()
+4 QUIT
STATUS(YSAU) ;Return status of unsigned ASIs on a user.
+1 if $GET(YSAU)'>0
SET YSAU=DUZ
+2 NEW YSAS,X
+3 SET YSAS=$$US(YSAU)
+4 FOR I=1:1:3
SET X=$PIECE(YSAS,U,I)
if X
Begin DoDot:1
+5 WRITE !,"You have ",$JUSTIFY(X,3)," unsigned ASI ",$SELECT(I=2:"Lite",I=3:"Followup",1:"Full Intake"),$SELECT(X>1:"s",1:""),"."
+6 QUIT
End DoDot:1
+7 QUIT
RACE(X) ;Pass file 2 race code and return ASI race code, if possible.
+1 if $GET(X)'>0
QUIT ""
+2 IF X=1
QUIT 2
+3 IF X=3
QUIT 1
+4 IF X=5
QUIT 5
+5 QUIT ""
+6 ;
REL(X) ;Pass file 2 religion code and return ASI religion code, if possible.
+1 if $GET(X)'>0
QUIT ""
+2 IF X=1
QUIT 3
+3 IF X=20
QUIT 4
+4 IF X=22
QUIT 5
+5 IF X=99
QUIT 2
+6 QUIT ""
+7 ;
