- 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 Feb 18, 2025@23:44:42 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