YTQPXRM7 ;ALB/ASF- PSYCH TEST API FOR CLINICAL REMINDERS ; 2/22/08 1:47pm
;;5.01;MENTAL HEALTH;**85,96**;Dec 30, 1994;Build 46
;Reference to ^PXRMINDX(601.2, supported by DBIA #4114
;Reference to ^DPT( supported by DBIA #10035
;Reference to ^VA(200, supported by DBIA #10060
;Reference to ^XUSEC( supported by DBIA #10076
;Reference to ^XLFDT APIs supported by DBIA #10103
SET(X) ;
S N=N+1
S YSDATA(N)=X
Q
DASASI ;
K YSSONE
S N=0,N2=0,IFN=$P(DAS,";",5)
I '$D(^YSTX(604,IFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no asi match" Q
D SET("[DATA]")
S YSADATE=$P(^YSTX(604,IFN,0),U,5)
S X=$P(^DPT(DFN,0),U)_"^ASI^--- Addiction Severity Index ---^"_YSADATE_U_$$FMTE^XLFDT(YSADATE,"5ZD")_U_$$GET1^DIQ(604,IFN_",",.09,"E")
D SET(X)
S YSDATA("S",1)="S1^Medical^"_$$GET1^DIQ(604,IFN_",",8.12)_U_$$GET1^DIQ(604,IFN_",",.61)
S YSDATA("S",2)="S2^Employment^"_$$GET1^DIQ(604,IFN_",",9.34)_U_$$GET1^DIQ(604,IFN_",",.62)
S YSDATA("S",3)="S3^Alcohol^"_$$GET1^DIQ(604,IFN_",",11.18)_U_$$GET1^DIQ(604,IFN_",",.63)
S YSDATA("S",4)="S4^Drug^"_$$GET1^DIQ(604,IFN_",",11.185)_U_$$GET1^DIQ(604,IFN_",",.635)
S YSDATA("S",5)="S5^Legal^"_$$GET1^DIQ(604,IFN_",",14.34)_U_$$GET1^DIQ(604,IFN_",",.64)
S YSDATA("S",6)="S6^Family^"_$$GET1^DIQ(604,IFN_",",18.29)_U_$$GET1^DIQ(604,IFN_",",.65)
S YSDATA("S",7)="S7^Psychiatric^"_$$GET1^DIQ(604,IFN_",",19.33)_U_$$GET1^DIQ(604,IFN_",",.66)
Q
LEGDAS(YSDATA,DAS) ;scoring for clinical reminder DAS entry
N R,S,A,B,C,G,H,I,I1,J,K,L,L1,L2,M,N,N1,N2,P,P3,P4,P5,T,T1,V,W,X,X1,X2,X3,X4,Y,Y1,Y2,YS10,YS25,YS50,YS75,YS90,YSAD,YSAGE,YSANLL,YSAS,YSAST,YSAU,YSB1,YSB2,YSBOX,YSBR
N YSBV,YSCALEN,YSCALET,YSCF,YSCF1,YSCNT,YSDAT,YSDATES,YSDOB,YSDS,YSED,YSED1,YSEP,YSET,YSF,YSFC,YSFR,YSHP1,YSHP2,YSHS,YSII,YSIN2,YSINC,YSIO,YSIT,YSIT1,YSIT2,YSIX,YSJJ,YSKC,YSKK,YSKY,YSLB,YSLE,YSLL
N YSLM,YSLN,YSLNE,YSLV,YSMA,YSMF,YSMMPI,YSMMPR,YSMX,YSN,YSNAM,YSND,YSNM,YSNS,YSNS26,YSNS39,YSNS9,YSNSCALE,YSNSS,YSOCAT,YSOCNM,YSOCP,YSOCSX,YSOFF,YSPD,YSPS,YSPT,YSQ,YSQR,YSRAW,YSRH,YSRM,YSRP,YSRR,YSRS,YSRT,YSS,YSS1,YSS2
N YSSC,YSSCALE,YSSCALEB,YSSEX,YSSH,YSSI,YSSK,YSSNM,YSSNM1,YSSNUMB,YSSP,YSSP4,YSSR,YSSS,YSSSN,YSSX,YSTAR,YSTEST,YSTESTA,YSTL,YSTN,YSTR,YSTTL,YSTV,YSTVL,YSTY,YSULOF,YSULON,YSVS,YSWF,YSX,YSXN,YSXR,YSXX,YSZ,Z,Z1,Z2
N IFN,N4,R3,SFN1,SFN2,YSAA,YSADATE,YSBED,YSBEG,YSCK,YSCODE,YSED,YSEND,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
S DAS=$P(DAS,U)
S YSCODE=$P(DAS,";",3)
I YSCODE'?1N.N D ERR("bad test code") Q ;-->OUT
S YSCODEN=$P(^YTT(601,YSCODE,0),U)
S DFN=$P(DAS,";")
I DFN'?1N.NP D ERR("bad dfn") Q ;--> OUT
S (IFN,YSADATE)=$P(DAS,";",5)
I IFN'>0 D ERR("bad IFN") Q ;-->out
I YSCODEN="GAF" D GAF Q ;--> out
I YSCODEN="ASI" D DASASI Q ;-->out
I YSADATE'?7N.E D ERR("bad date") Q ;-->OUT
;;score me
SCOR1 S (YSTEST,YSET)=YSCODE
S YSED=YSADATE
S YSDFN=DFN
S YSSX=$P(^DPT(DFN,0),U,2)
S YSTN=YSCODEN
IF '$D(^YTD(601.2,YSDFN,1,YSET,1,YSED)) S YSDATA(1)="[ERROR SCORE1 NEW]",YSDATA(2)="no administration found" Q
D PRIV ;check it
Q:YSPRIV=0
S YSR(0)=$G(^YTT(601.6,YSET,0))
I $P(YSR(0),U,2)="Y" S X=^YTT(601.6,YSET,1) X X
Q:$G(YSDATA(1))?1"[ERROR".E
;;
SCORSET ;;heading data name^code^title^comp date^ordered by
S N=0 D SET("[DATA]")
S X=$P($G(^YTD(601.2,YSDFN,1,YSET,1,YSED,0)),U,3)
S X=$S(X?1N.N:$P($G(^VA(200,X,0)),U,1),1:"")
S X=$P(^DPT(DFN,0),U)_U_YSCODE_U_$P($G(^YTT(601,YSET,"P")),U)_U_YSED_U_$$FMTE^XLFDT(YSADATE,"5ZD")_U_X
D SET(X)
I YSPRIV=0 D SET("no privilege") Q
;no return of responses for legacy tests ASF 2/22/07
;S G=$G(^YTD(601.2,DFN,1,YSET,1,YSED,1)) F I=1:1 S A=$E(G,I) Q:A="" S N1=N1+1,YSDATA("R",N1)="^^^^"_A_U_A
D:YSPRIV SF^YTAPI2
S N1=0
F S N1=$O(YSSONE(N1)) Q:N1'>0 S YSDATA("S",N1)=YSSONE(N1)
Q
GAF ;score gafs
I '$D(^YSD(627.8,IFN,60)) D ERR("no ax5 ifn") Q ;-->out
S N=0,G=^YSD(627.8,IFN,0) D SET("[DATA]")
S X=$P($G(^DPT(DFN,0)),U)_"^GAF^GAF^"_$P(G,U,3)_U_$$EXTERNAL^DILFD(627.8,.03,"",$P(G,U,3))_U_$$EXTERNAL^DILFD(627.8,.04,"",$P(G,U,4)) ;asf 2/13/04
D SET(X)
;S YSDATA("R",1)="^^^^^"_$P($G(^YSD(627.8,IFN,60)),U,3)
S YSDATA("S",1)="S1^GAF^"_$P($G(^YSD(627.8,IFN,60)),U,3)_U_$G(^YSD(627.8,IFN,80,1,0))
Q
ERR(YSX) ;errors
S YSDATA(0)="[ERROR]",YSDATA(1)=YSX
Q
PRIV ;check privileges
N YS71,YSKEY
S YSPRIV=0
S YS71=$O(^YTT(601.71,"B",YSCODEN,0))
Q:YS71="" ;-->out error
S YSKEY=$$GET1^DIQ(601.71,YS71_",",9)
I YSKEY="" S YSPRIV=1 Q ;-->out exempt
I $D(^XUSEC(YSKEY,DUZ)) S YSPRIV=1 Q ;-->out has key
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM7 4526 printed Apr 09, 2024@21:24:31 Page 2
YTQPXRM7 ;ALB/ASF- PSYCH TEST API FOR CLINICAL REMINDERS ; 2/22/08 1:47pm
+1 ;;5.01;MENTAL HEALTH;**85,96**;Dec 30, 1994;Build 46
+2 ;Reference to ^PXRMINDX(601.2, supported by DBIA #4114
+3 ;Reference to ^DPT( supported by DBIA #10035
+4 ;Reference to ^VA(200, supported by DBIA #10060
+5 ;Reference to ^XUSEC( supported by DBIA #10076
+6 ;Reference to ^XLFDT APIs supported by DBIA #10103
SET(X) ;
+1 SET N=N+1
+2 SET YSDATA(N)=X
+3 QUIT
DASASI ;
+1 KILL YSSONE
+2 SET N=0
SET N2=0
SET IFN=$PIECE(DAS,";",5)
+3 IF '$DATA(^YSTX(604,IFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no asi match"
QUIT
+4 DO SET("[DATA]")
+5 SET YSADATE=$PIECE(^YSTX(604,IFN,0),U,5)
+6 SET X=$PIECE(^DPT(DFN,0),U)_"^ASI^--- Addiction Severity Index ---^"_YSADATE_U_$$FMTE^XLFDT(YSADATE,"5ZD")_U_$$GET1^DIQ(604,IFN_",",.09,"E")
+7 DO SET(X)
+8 SET YSDATA("S",1)="S1^Medical^"_$$GET1^DIQ(604,IFN_",",8.12)_U_$$GET1^DIQ(604,IFN_",",.61)
+9 SET YSDATA("S",2)="S2^Employment^"_$$GET1^DIQ(604,IFN_",",9.34)_U_$$GET1^DIQ(604,IFN_",",.62)
+10 SET YSDATA("S",3)="S3^Alcohol^"_$$GET1^DIQ(604,IFN_",",11.18)_U_$$GET1^DIQ(604,IFN_",",.63)
+11 SET YSDATA("S",4)="S4^Drug^"_$$GET1^DIQ(604,IFN_",",11.185)_U_$$GET1^DIQ(604,IFN_",",.635)
+12 SET YSDATA("S",5)="S5^Legal^"_$$GET1^DIQ(604,IFN_",",14.34)_U_$$GET1^DIQ(604,IFN_",",.64)
+13 SET YSDATA("S",6)="S6^Family^"_$$GET1^DIQ(604,IFN_",",18.29)_U_$$GET1^DIQ(604,IFN_",",.65)
+14 SET YSDATA("S",7)="S7^Psychiatric^"_$$GET1^DIQ(604,IFN_",",19.33)_U_$$GET1^DIQ(604,IFN_",",.66)
+15 QUIT
LEGDAS(YSDATA,DAS) ;scoring for clinical reminder DAS entry
+1 NEW R,S,A,B,C,G,H,I,I1,J,K,L,L1,L2,M,N,N1,N2,P,P3,P4,P5,T,T1,V,W,X,X1,X2,X3,X4,Y,Y1,Y2,YS10,YS25,YS50,YS75,YS90,YSAD,YSAGE,YSANLL,YSAS,YSAST,YSAU,YSB1,YSB2,YSBOX,YSBR
+2 NEW YSBV,YSCALEN,YSCALET,YSCF,YSCF1,YSCNT,YSDAT,YSDATES,YSDOB,YSDS,YSED,YSED1,YSEP,YSET,YSF,YSFC,YSFR,YSHP1,YSHP2,YSHS,YSII,YSIN2,YSINC,YSIO,YSIT,YSIT1,YSIT2,YSIX,YSJJ,YSKC,YSKK,YSKY,YSLB,YSLE,YSLL
+3 NEW YSLM,YSLN,YSLNE,YSLV,YSMA,YSMF,YSMMPI,YSMMPR,YSMX,YSN,YSNAM,YSND,YSNM,YSNS,YSNS26,YSNS39,YSNS9,YSNSCALE,YSNSS,YSOCAT,YSOCNM,YSOCP,YSOCSX,YSOFF,YSPD,YSPS,YSPT,YSQ,YSQR,YSRAW,YSRH,YSRM,YSRP,YSRR,YSRS,YSRT,YSS,YSS1,YSS2
+4 NEW YSSC,YSSCALE,YSSCALEB,YSSEX,YSSH,YSSI,YSSK,YSSNM,YSSNM1,YSSNUMB,YSSP,YSSP4,YSSR,YSSS,YSSSN,YSSX,YSTAR,YSTEST,YSTESTA,YSTL,YSTN,YSTR,YSTTL,YSTV,YSTVL,YSTY,YSULOF,YSULON,YSVS,YSWF,YSX,YSXN,YSXR,YSXX,YSZ,Z,Z1,Z2
+5 NEW IFN,N4,R3,SFN1,SFN2,YSAA,YSADATE,YSBED,YSBEG,YSCK,YSCODE,YSED,YSEND,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
+6 SET DAS=$PIECE(DAS,U)
+7 SET YSCODE=$PIECE(DAS,";",3)
+8 ;-->OUT
IF YSCODE'?1N.N
DO ERR("bad test code")
QUIT
+9 SET YSCODEN=$PIECE(^YTT(601,YSCODE,0),U)
+10 SET DFN=$PIECE(DAS,";")
+11 ;--> OUT
IF DFN'?1N.NP
DO ERR("bad dfn")
QUIT
+12 SET (IFN,YSADATE)=$PIECE(DAS,";",5)
+13 ;-->out
IF IFN'>0
DO ERR("bad IFN")
QUIT
+14 ;--> out
IF YSCODEN="GAF"
DO GAF
QUIT
+15 ;-->out
IF YSCODEN="ASI"
DO DASASI
QUIT
+16 ;-->OUT
IF YSADATE'?7N.E
DO ERR("bad date")
QUIT
+17 ;;score me
SCOR1 SET (YSTEST,YSET)=YSCODE
+1 SET YSED=YSADATE
+2 SET YSDFN=DFN
+3 SET YSSX=$PIECE(^DPT(DFN,0),U,2)
+4 SET YSTN=YSCODEN
+5 IF '$DATA(^YTD(601.2,YSDFN,1,YSET,1,YSED))
SET YSDATA(1)="[ERROR SCORE1 NEW]"
SET YSDATA(2)="no administration found"
QUIT
+6 ;check it
DO PRIV
+7 if YSPRIV=0
QUIT
+8 SET YSR(0)=$GET(^YTT(601.6,YSET,0))
+9 IF $PIECE(YSR(0),U,2)="Y"
SET X=^YTT(601.6,YSET,1)
XECUTE X
+10 if $GET(YSDATA(1))?1"[ERROR".E
QUIT
+11 ;;
SCORSET ;;heading data name^code^title^comp date^ordered by
+1 SET N=0
DO SET("[DATA]")
+2 SET X=$PIECE($GET(^YTD(601.2,YSDFN,1,YSET,1,YSED,0)),U,3)
+3 SET X=$SELECT(X?1N.N:$PIECE($GET(^VA(200,X,0)),U,1),1:"")
+4 SET X=$PIECE(^DPT(DFN,0),U)_U_YSCODE_U_$PIECE($GET(^YTT(601,YSET,"P")),U)_U_YSED_U_$$FMTE^XLFDT(YSADATE,"5ZD")_U_X
+5 DO SET(X)
+6 IF YSPRIV=0
DO SET("no privilege")
QUIT
+7 ;no return of responses for legacy tests ASF 2/22/07
+8 ;S G=$G(^YTD(601.2,DFN,1,YSET,1,YSED,1)) F I=1:1 S A=$E(G,I) Q:A="" S N1=N1+1,YSDATA("R",N1)="^^^^"_A_U_A
+9 if YSPRIV
DO SF^YTAPI2
+10 SET N1=0
+11 FOR
SET N1=$ORDER(YSSONE(N1))
if N1'>0
QUIT
SET YSDATA("S",N1)=YSSONE(N1)
+12 QUIT
GAF ;score gafs
+1 ;-->out
IF '$DATA(^YSD(627.8,IFN,60))
DO ERR("no ax5 ifn")
QUIT
+2 SET N=0
SET G=^YSD(627.8,IFN,0)
DO SET("[DATA]")
+3 ;asf 2/13/04
SET X=$PIECE($GET(^DPT(DFN,0)),U)_"^GAF^GAF^"_$PIECE(G,U,3)_U_$$EXTERNAL^DILFD(627.8,.03,"",$PIECE(G,U,3))_U_$$EXTERNAL^DILFD(627.8,.04,"",$PIECE(G,U,4))
+4 DO SET(X)
+5 ;S YSDATA("R",1)="^^^^^"_$P($G(^YSD(627.8,IFN,60)),U,3)
+6 SET YSDATA("S",1)="S1^GAF^"_$PIECE($GET(^YSD(627.8,IFN,60)),U,3)_U_$GET(^YSD(627.8,IFN,80,1,0))
+7 QUIT
ERR(YSX) ;errors
+1 SET YSDATA(0)="[ERROR]"
SET YSDATA(1)=YSX
+2 QUIT
PRIV ;check privileges
+1 NEW YS71,YSKEY
+2 SET YSPRIV=0
+3 SET YS71=$ORDER(^YTT(601.71,"B",YSCODEN,0))
+4 ;-->out error
if YS71=""
QUIT
+5 SET YSKEY=$$GET1^DIQ(601.71,YS71_",",9)
+6 ;-->out exempt
IF YSKEY=""
SET YSPRIV=1
QUIT
+7 ;-->out has key
IF $DATA(^XUSEC(YSKEY,DUZ))
SET YSPRIV=1
QUIT
+8 QUIT
