- 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 Feb 18, 2025@23:39:27 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 ;