YTQAPI9 ;ALB/ASF - MHA ENTRIES ; 12/12/09 5:02pm
;;5.01;MENTAL HEALTH;**85,96,119,121,142**;Dec 30, 1994;Build 14
;
;Reference to ^DPT( supported by DBIA #10035
;Reference to VADPT APIs supported by DBIA #10061
;Reference to ^XUSEC( supported by DBIA #10076
;Reference to ^XUSRB APIs supported by DBIA #3277
;Reference to ^VA(200, supported by DBIA #10060
;Reference to VASITE APIs supported by DBIA #10112
;Reference to FILE 8925.1 supported by DBIA #5033
;Reference to TIUSRVA APIs supported by DBIA #5541
;Reference to TIUFLF7 APIs supported by DBIA #5352
Q
LEGCR(YSDATA,YS) ;score/report for cr dll, RPC: YTQ LEGCR
;entry point for YTQ LEGCR rpc
;input: YS("ADATE")=date of admin
; YS("DFN") as pt ien
; YS("CODE") as test name
; YS("R1") as first 200 legacy codes in a string
; YS("R2") as 201-400
N DA,DIK,DFN,YSNCODE,YSCODE,YSADATE,YSJ,YSDFN,VA,VADM,YSDT,YSE,YSEND,YSLIMIT,YSN,YSS,YSSCALE,YSCALE1,VAERR,Y,R1,R2,R3,N,J,YSAGE,YSDOB,YSG,YSHDR,YSNM,YSSEX,YSSSN,VADM,YSQQ,YSC1,YSG1,YSRT,YSRTI
K ^TMP($J,"YTAPI4")
D PARSE^YTAPI(.YS)
I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no such pt" Q
I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="INCORRECT TEST CODE" Q ;---> bad code
S YSNCODE=$O(^YTT(601,"B",YSCODE,-1))
I YSADATE'=DT S YSDATA(1)="[ERROR]",YSDATA(2)="bad date needs DT" Q ;---> bad date
L +^YTD(601.2,DFN,1,YSNCODE,1,YSADATE):DILOCKTM I '$T S YSDATA(1)="[ERROR]",YSDATA(2)="no lock" Q ;--->
D:$D(^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)) INTMP ;save old testing for a day
D SAVEIT^YTAPI1(.YSDATA,.YS) ; save responses
S YSCODEN=$O(^YTT(601.71,"B",YSCODE,0))
D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
S N2=0 F S N2=$O(YSQQ("S",N2)) Q:N2'>0 D
. S YSCALE1=YSQQ("S",N2)
. S YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
K YSQQ
D SCOREIT^YTQAPI14(.YSDATA,.YS) I $G(YSDATA(1))?1"[ERROR".E L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE) Q
;scale listing
S N2=5 F S N2=$O(YSDATA(N2)) Q:N2'>0 D
. S YSG1=YSDATA(N2),YSCALE1=$P(YSG1,U,2),YSRT=$P(YSG1,U,3,4)
. S YSRTI=$O(YSC1($$UCASE^YTQPXRM6(YSCALE1),0))
. S:YSRTI'="" YSDATA(N2)=$P(YSG1,U)_U_YSCALE1_U_YSRTI_U_YSRT
D INTRMNT^YTRPWRP(.YSDATA,DFN,YSADATE_","_YSNCODE)
D DEM^VADPT,PID^VADPT S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN=VA("PID")
S $P(YSHDR," ",60)="",YSHDR="xxx-xx-"_$E(YSSSN,8,11)_" "_YSNM_YSHDR,YSHDR=$E(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
AA S YSJ=$O(YSDATA(999),-1)
S YSDATA(YSJ+1)="^^PROGRESS NOTE^^"
S N=3,J=1 F S N=$O(^TMP("YSDATA",$J,1,N)) Q:N'>0 D
. S YSG=^TMP("YSDATA",$J,1,N)
. Q:YSG]YSHDR
. Q:YSG?1"Not valid unless signed: Reviewed by".E
. Q:YSG?1"Printed by: ".E
. Q:YSG?." "1"PRINTED ENTERED"." "
. Q:YSG?1"Ordered by: ".E
. S J=J+1,YSDATA(YSJ+J)=YSG
DROP ;kill preview data
S DIK="^YTD(601.2,DFN,1,YSNCODE,1,",DA=YSADATE,DA(1)=YSNCODE,DA(2)=DFN D ^DIK
;
D:$D(^TMP($J,"YTAPI4")) OUTTMP ;place back old testing
S DIK="^YTD(601.2,",DA=DFN D IX^DIK ; reindex
L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
K YSQQ Q
INTMP ; SAVE OLD
M ^TMP($J,"YTAPI4")=^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
Q
OUTTMP ;replace old testing
M ^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)=^TMP($J,"YTAPI4")
Q
NATSET(YSDATA,YS) ; set design environment to save fm entries <100,000
;entry point for YTQ SET NATIONAL rpc
;input: NATIONAL as Yes or No
;output: YSPROG=1
N Y1
I '$D(^XUSEC("YSPROG",DUZ)) S YSDATA(1)="[ERROR]",YSDATA(2)="no prog key" Q ;-->out
S Y1=$G(YS("NATIONAL"))
S Y1=$E(Y1,1)
I (Y1'="Y")&(Y1'="N") S YSDATA(1)="[ERROR]",YSDATA(2)="no/BAD setting"
S YSDATA(1)="[DATA]"
I Y1="N" K YSPROG S YSDATA(2)="local editing set"
I Y1="Y" S YSPROG=1,YSDATA(2)="national editing set"
Q
PATSEL(YSDATA,YS) ;patient component
;entry point for YTQ PATIENT INFO rpc
;input DFN as ien of file 2
;output
; YSDATA(2)= name
; YSDATA(3)=ssn
; YSDATA(4)=dob
; YSDATA(5)=age
; YSDATA(6)=sex
; YSDATA(7)=date of death (or 0)
; YSDATA(8)=0 NCS/ 1 SC^%^service connected
N DFN,VADM,VAEL,VAERR
S DFN=$G(YS("DFN"),-1)
I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad dfn" Q ;-->out
D 2^VADPT
I VAERR=1 S YSDATA(1)="[ERROR]",YSDATA(2)="vadpt err" Q ;-->out
S YSDATA(1)="[DATA]"
S YSDATA(2)=VADM(1)_U_"name"
S YSDATA(3)=VADM(2)_U_"ssn"
S YSDATA(4)=VADM(3)_U_"dob"
S YSDATA(5)=VADM(4)_U_"age"
S YSDATA(6)=VADM(5)_U_"sex"
S YSDATA(7)=+VADM(6)_U_$P(VADM(6),U,2)_U_"date of death"
S YSDATA(8)=VAEL(3)_U_"service connected"
Q
USERQ(YSDATA,YS) ;user info
;entry point for YTQ USERQ rpc
;input DUZ as internal ien file 200 for user to check [optional default is current user]
; KEY as name of security key to check [optional]
; TITLE as name of Pnote [optional]
;output YSDATA(2)= name of user
; YSDATA(3) if key sent 1^holds VS 0^lacks KEY
; YSDATA(4) site info
N K,YSKEY,YSDUZ,YSTITLE,DIC,YSCOS,N2,X
S YSTITLE=$G(YS("TITLE"),-1)
S YSDUZ=$G(YS("DUZ"),DUZ)
S YSKEY=$G(YS("KEY"),-1)
S YSTITLE=$G(YS("TITLE"))
S YSDATA(1)="[DATA]"
D OWNSKEY^XUSRB(.K,YSKEY,YSDUZ)
S YSDATA(2)=$P($G(^VA(200,YSDUZ,0)),U)_U_YSDUZ
I YSKEY=-1 S YSDATA(3)=""
E S YSDATA(3)=$S(K(0):"1^holds ",1:"0^lacks ")_YSKEY
S YSDATA(4)=$$SITE^VASITE_U_$$NAME^VASITE(DT)
;ASF 12/8/2009
I YSTITLE="" S YSDATA(5)="^no title sent" Q ;-->out
S Y=+$$DDEFIEN^TIUFLF7(YSTITLE,"TL")
I +Y'>0 S YSDATA(5)="^bad pnote title" Q ;-->out
D REQCOS^TIUSRVA(.YSCOS,+Y,"",YSDUZ) ;is cosigner required
S YSDATA(5)=YSCOS_U_"cosigner "_$S(YSCOS=1:"required",YSCOS=0:"not required",1:"error")
Q
MHREPORT(YSDATA,YS) ;gets a report format from 601.93
;entry point for YTQ GET REPORT rpc
;Input: CODE as instrument name
;Output: LINE# ^ line text
N N,N1,YSIENS,YSCODE,YSCODEN,YSIENS
K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
S ^TMP("YSDATA",$J,1)="[ERROR]"
S YSCODE=$G(YS("CODE"),0)
I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP("YSDATA",$J,2)="bad code" Q ;-->out
S YSCODEN=$O(^YTT(601.71,"B",YSCODE,-1))
S YSIENS=$O(^YTT(601.93,"C",YSCODEN,-1))
I YSIENS'>0 S ^TMP("YSDATA",$J,1)="[DATA]^0" Q ;--> out
S N=1,N1=0 F S N1=$O(^YTT(601.93,YSIENS,1,N1)) Q:N1'>0 D
. S N=N+1,^TMP("YSDATA",$J,N)=$G(^YTT(601.93,YSIENS,1,N1,0))
S ^TMP("YSDATA",$J,1)="[DATA]"_U_YSIENS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI9 6300 printed Sep 23, 2025@19:54:30 Page 2
YTQAPI9 ;ALB/ASF - MHA ENTRIES ; 12/12/09 5:02pm
+1 ;;5.01;MENTAL HEALTH;**85,96,119,121,142**;Dec 30, 1994;Build 14
+2 ;
+3 ;Reference to ^DPT( supported by DBIA #10035
+4 ;Reference to VADPT APIs supported by DBIA #10061
+5 ;Reference to ^XUSEC( supported by DBIA #10076
+6 ;Reference to ^XUSRB APIs supported by DBIA #3277
+7 ;Reference to ^VA(200, supported by DBIA #10060
+8 ;Reference to VASITE APIs supported by DBIA #10112
+9 ;Reference to FILE 8925.1 supported by DBIA #5033
+10 ;Reference to TIUSRVA APIs supported by DBIA #5541
+11 ;Reference to TIUFLF7 APIs supported by DBIA #5352
+12 QUIT
LEGCR(YSDATA,YS) ;score/report for cr dll, RPC: YTQ LEGCR
+1 ;entry point for YTQ LEGCR rpc
+2 ;input: YS("ADATE")=date of admin
+3 ; YS("DFN") as pt ien
+4 ; YS("CODE") as test name
+5 ; YS("R1") as first 200 legacy codes in a string
+6 ; YS("R2") as 201-400
+7 NEW DA,DIK,DFN,YSNCODE,YSCODE,YSADATE,YSJ,YSDFN,VA,VADM,YSDT,YSE,YSEND,YSLIMIT,YSN,YSS,YSSCALE,YSCALE1,VAERR,Y,R1,R2,R3,N,J,YSAGE,YSDOB,YSG,YSHDR,YSNM,YSSEX,YSSSN,VADM,YSQQ,YSC1,YSG1,YSRT,YSRTI
+8 KILL ^TMP($JOB,"YTAPI4")
+9 DO PARSE^YTAPI(.YS)
+10 IF '$DATA(^DPT(DFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no such pt"
QUIT
+11 ;---> bad code
IF '$DATA(^YTT(601,"B",YSCODE))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="INCORRECT TEST CODE"
QUIT
+12 SET YSNCODE=$ORDER(^YTT(601,"B",YSCODE,-1))
+13 ;---> bad date
IF YSADATE'=DT
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad date needs DT"
QUIT
+14 ;--->
LOCK +^YTD(601.2,DFN,1,YSNCODE,1,YSADATE):DILOCKTM
IF '$TEST
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no lock"
QUIT
+15 ;save old testing for a day
if $DATA(^YTD(601.2,DFN,1,YSNCODE,1,YSADATE))
DO INTMP
+16 ; save responses
DO SAVEIT^YTAPI1(.YSDATA,.YS)
+17 SET YSCODEN=$ORDER(^YTT(601.71,"B",YSCODE,0))
+18 DO SCALES^YTQPXRM5(.YSQQ,YSCODEN)
+19 SET N2=0
FOR
SET N2=$ORDER(YSQQ("S",N2))
if N2'>0
QUIT
Begin DoDot:1
+20 SET YSCALE1=YSQQ("S",N2)
+21 SET YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
End DoDot:1
+22 KILL YSQQ
+23 DO SCOREIT^YTQAPI14(.YSDATA,.YS)
IF $GET(YSDATA(1))?1"[ERROR".E
LOCK -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
QUIT
+24 ;scale listing
+25 SET N2=5
FOR
SET N2=$ORDER(YSDATA(N2))
if N2'>0
QUIT
Begin DoDot:1
+26 SET YSG1=YSDATA(N2)
SET YSCALE1=$PIECE(YSG1,U,2)
SET YSRT=$PIECE(YSG1,U,3,4)
+27 SET YSRTI=$ORDER(YSC1($$UCASE^YTQPXRM6(YSCALE1),0))
+28 if YSRTI'=""
SET YSDATA(N2)=$PIECE(YSG1,U)_U_YSCALE1_U_YSRTI_U_YSRT
End DoDot:1
+29 DO INTRMNT^YTRPWRP(.YSDATA,DFN,YSADATE_","_YSNCODE)
+30 DO DEM^VADPT
DO PID^VADPT
SET YSNM=VADM(1)
SET YSSEX=$PIECE(VADM(5),U)
SET YSDOB=$PIECE(VADM(3),U,2)
SET YSAGE=VADM(4)
SET YSSSN=VA("PID")
+31 SET $PIECE(YSHDR," ",60)=""
SET YSHDR="xxx-xx-"_$EXTRACT(YSSSN,8,11)_" "_YSNM_YSHDR
SET YSHDR=$EXTRACT(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
AA SET YSJ=$ORDER(YSDATA(999),-1)
+1 SET YSDATA(YSJ+1)="^^PROGRESS NOTE^^"
+2 SET N=3
SET J=1
FOR
SET N=$ORDER(^TMP("YSDATA",$JOB,1,N))
if N'>0
QUIT
Begin DoDot:1
+3 SET YSG=^TMP("YSDATA",$JOB,1,N)
+4 if YSG]YSHDR
QUIT
+5 if YSG?1"Not valid unless signed
QUIT
+6 if YSG?1"Printed by
QUIT
+7 if YSG?." "1"PRINTED ENTERED"." "
QUIT
+8 if YSG?1"Ordered by
QUIT
+9 SET J=J+1
SET YSDATA(YSJ+J)=YSG
End DoDot:1
DROP ;kill preview data
+1 SET DIK="^YTD(601.2,DFN,1,YSNCODE,1,"
SET DA=YSADATE
SET DA(1)=YSNCODE
SET DA(2)=DFN
DO ^DIK
+2 ;
+3 ;place back old testing
if $DATA(^TMP($JOB,"YTAPI4"))
DO OUTTMP
+4 ; reindex
SET DIK="^YTD(601.2,"
SET DA=DFN
DO IX^DIK
+5 LOCK -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
+6 KILL YSQQ
QUIT
INTMP ; SAVE OLD
+1 MERGE ^TMP($JOB,"YTAPI4")=^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
+2 QUIT
OUTTMP ;replace old testing
+1 MERGE ^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)=^TMP($JOB,"YTAPI4")
+2 QUIT
NATSET(YSDATA,YS) ; set design environment to save fm entries <100,000
+1 ;entry point for YTQ SET NATIONAL rpc
+2 ;input: NATIONAL as Yes or No
+3 ;output: YSPROG=1
+4 NEW Y1
+5 ;-->out
IF '$DATA(^XUSEC("YSPROG",DUZ))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no prog key"
QUIT
+6 SET Y1=$GET(YS("NATIONAL"))
+7 SET Y1=$EXTRACT(Y1,1)
+8 IF (Y1'="Y")&(Y1'="N")
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no/BAD setting"
+9 SET YSDATA(1)="[DATA]"
+10 IF Y1="N"
KILL YSPROG
SET YSDATA(2)="local editing set"
+11 IF Y1="Y"
SET YSPROG=1
SET YSDATA(2)="national editing set"
+12 QUIT
PATSEL(YSDATA,YS) ;patient component
+1 ;entry point for YTQ PATIENT INFO rpc
+2 ;input DFN as ien of file 2
+3 ;output
+4 ; YSDATA(2)= name
+5 ; YSDATA(3)=ssn
+6 ; YSDATA(4)=dob
+7 ; YSDATA(5)=age
+8 ; YSDATA(6)=sex
+9 ; YSDATA(7)=date of death (or 0)
+10 ; YSDATA(8)=0 NCS/ 1 SC^%^service connected
+11 NEW DFN,VADM,VAEL,VAERR
+12 SET DFN=$GET(YS("DFN"),-1)
+13 ;-->out
IF '$DATA(^DPT(DFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad dfn"
QUIT
+14 DO 2^VADPT
+15 ;-->out
IF VAERR=1
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="vadpt err"
QUIT
+16 SET YSDATA(1)="[DATA]"
+17 SET YSDATA(2)=VADM(1)_U_"name"
+18 SET YSDATA(3)=VADM(2)_U_"ssn"
+19 SET YSDATA(4)=VADM(3)_U_"dob"
+20 SET YSDATA(5)=VADM(4)_U_"age"
+21 SET YSDATA(6)=VADM(5)_U_"sex"
+22 SET YSDATA(7)=+VADM(6)_U_$PIECE(VADM(6),U,2)_U_"date of death"
+23 SET YSDATA(8)=VAEL(3)_U_"service connected"
+24 QUIT
USERQ(YSDATA,YS) ;user info
+1 ;entry point for YTQ USERQ rpc
+2 ;input DUZ as internal ien file 200 for user to check [optional default is current user]
+3 ; KEY as name of security key to check [optional]
+4 ; TITLE as name of Pnote [optional]
+5 ;output YSDATA(2)= name of user
+6 ; YSDATA(3) if key sent 1^holds VS 0^lacks KEY
+7 ; YSDATA(4) site info
+8 NEW K,YSKEY,YSDUZ,YSTITLE,DIC,YSCOS,N2,X
+9 SET YSTITLE=$GET(YS("TITLE"),-1)
+10 SET YSDUZ=$GET(YS("DUZ"),DUZ)
+11 SET YSKEY=$GET(YS("KEY"),-1)
+12 SET YSTITLE=$GET(YS("TITLE"))
+13 SET YSDATA(1)="[DATA]"
+14 DO OWNSKEY^XUSRB(.K,YSKEY,YSDUZ)
+15 SET YSDATA(2)=$PIECE($GET(^VA(200,YSDUZ,0)),U)_U_YSDUZ
+16 IF YSKEY=-1
SET YSDATA(3)=""
+17 IF '$TEST
SET YSDATA(3)=$SELECT(K(0):"1^holds ",1:"0^lacks ")_YSKEY
+18 SET YSDATA(4)=$$SITE^VASITE_U_$$NAME^VASITE(DT)
+19 ;ASF 12/8/2009
+20 ;-->out
IF YSTITLE=""
SET YSDATA(5)="^no title sent"
QUIT
+21 SET Y=+$$DDEFIEN^TIUFLF7(YSTITLE,"TL")
+22 ;-->out
IF +Y'>0
SET YSDATA(5)="^bad pnote title"
QUIT
+23 ;is cosigner required
DO REQCOS^TIUSRVA(.YSCOS,+Y,"",YSDUZ)
+24 SET YSDATA(5)=YSCOS_U_"cosigner "_$SELECT(YSCOS=1:"required",YSCOS=0:"not required",1:"error")
+25 QUIT
MHREPORT(YSDATA,YS) ;gets a report format from 601.93
+1 ;entry point for YTQ GET REPORT rpc
+2 ;Input: CODE as instrument name
+3 ;Output: LINE# ^ line text
+4 NEW N,N1,YSIENS,YSCODE,YSCODEN,YSIENS
+5 KILL ^TMP("YSDATA",$JOB)
SET YSDATA=$NAME(^TMP("YSDATA",$JOB))
+6 SET ^TMP("YSDATA",$JOB,1)="[ERROR]"
+7 SET YSCODE=$GET(YS("CODE"),0)
+8 ;-->out
IF '$DATA(^YTT(601.71,"B",YSCODE))
SET ^TMP("YSDATA",$JOB,2)="bad code"
QUIT
+9 SET YSCODEN=$ORDER(^YTT(601.71,"B",YSCODE,-1))
+10 SET YSIENS=$ORDER(^YTT(601.93,"C",YSCODEN,-1))
+11 ;--> out
IF YSIENS'>0
SET ^TMP("YSDATA",$JOB,1)="[DATA]^0"
QUIT
+12 SET N=1
SET N1=0
FOR
SET N1=$ORDER(^YTT(601.93,YSIENS,1,N1))
if N1'>0
QUIT
Begin DoDot:1
+13 SET N=N+1
SET ^TMP("YSDATA",$JOB,N)=$GET(^YTT(601.93,YSIENS,1,N1,0))
End DoDot:1
+14 SET ^TMP("YSDATA",$JOB,1)="[DATA]"_U_YSIENS
+15 QUIT
