Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQAPI9

YTQAPI9.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;Reference to ^DPT( supported by DBIA #10035
  1. ;Reference to VADPT APIs supported by DBIA #10061
  1. ;Reference to ^XUSEC( supported by DBIA #10076
  1. ;Reference to ^XUSRB APIs supported by DBIA #3277
  1. ;Reference to ^VA(200, supported by DBIA #10060
  1. ;Reference to VASITE APIs supported by DBIA #10112
  1. ;Reference to FILE 8925.1 supported by DBIA #5033
  1. ;Reference to TIUSRVA APIs supported by DBIA #5541
  1. ;Reference to TIUFLF7 APIs supported by DBIA #5352
  1. Q
  1. LEGCR(YSDATA,YS) ;score/report for cr dll, RPC: YTQ LEGCR
  1. ;entry point for YTQ LEGCR rpc
  1. ;input: YS("ADATE")=date of admin
  1. ; YS("DFN") as pt ien
  1. ; YS("CODE") as test name
  1. ; YS("R1") as first 200 legacy codes in a string
  1. ; YS("R2") as 201-400
  1. 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
  1. K ^TMP($J,"YTAPI4")
  1. D PARSE^YTAPI(.YS)
  1. I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="no such pt" Q
  1. I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="INCORRECT TEST CODE" Q ;---> bad code
  1. S YSNCODE=$O(^YTT(601,"B",YSCODE,-1))
  1. I YSADATE'=DT S YSDATA(1)="[ERROR]",YSDATA(2)="bad date needs DT" Q ;---> bad date
  1. L +^YTD(601.2,DFN,1,YSNCODE,1,YSADATE):DILOCKTM I '$T S YSDATA(1)="[ERROR]",YSDATA(2)="no lock" Q ;--->
  1. D:$D(^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)) INTMP ;save old testing for a day
  1. D SAVEIT^YTAPI1(.YSDATA,.YS) ; save responses
  1. S YSCODEN=$O(^YTT(601.71,"B",YSCODE,0))
  1. D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
  1. S N2=0 F S N2=$O(YSQQ("S",N2)) Q:N2'>0 D
  1. . S YSCALE1=YSQQ("S",N2)
  1. . S YSC1($$UCASE^YTQPXRM6(YSCALE1),N2)=""
  1. K YSQQ
  1. D SCOREIT^YTQAPI14(.YSDATA,.YS) I $G(YSDATA(1))?1"[ERROR".E L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE) Q
  1. ;scale listing
  1. S N2=5 F S N2=$O(YSDATA(N2)) Q:N2'>0 D
  1. . S YSG1=YSDATA(N2),YSCALE1=$P(YSG1,U,2),YSRT=$P(YSG1,U,3,4)
  1. . S YSRTI=$O(YSC1($$UCASE^YTQPXRM6(YSCALE1),0))
  1. . S:YSRTI'="" YSDATA(N2)=$P(YSG1,U)_U_YSCALE1_U_YSRTI_U_YSRT
  1. D INTRMNT^YTRPWRP(.YSDATA,DFN,YSADATE_","_YSNCODE)
  1. 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")
  1. S $P(YSHDR," ",60)="",YSHDR="xxx-xx-"_$E(YSSSN,8,11)_" "_YSNM_YSHDR,YSHDR=$E(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
  1. AA S YSJ=$O(YSDATA(999),-1)
  1. S YSDATA(YSJ+1)="^^PROGRESS NOTE^^"
  1. S N=3,J=1 F S N=$O(^TMP("YSDATA",$J,1,N)) Q:N'>0 D
  1. . S YSG=^TMP("YSDATA",$J,1,N)
  1. . Q:YSG]YSHDR
  1. . Q:YSG?1"Not valid unless signed: Reviewed by".E
  1. . Q:YSG?1"Printed by: ".E
  1. . Q:YSG?." "1"PRINTED ENTERED"." "
  1. . Q:YSG?1"Ordered by: ".E
  1. . S J=J+1,YSDATA(YSJ+J)=YSG
  1. DROP ;kill preview data
  1. S DIK="^YTD(601.2,DFN,1,YSNCODE,1,",DA=YSADATE,DA(1)=YSNCODE,DA(2)=DFN D ^DIK
  1. ;
  1. D:$D(^TMP($J,"YTAPI4")) OUTTMP ;place back old testing
  1. S DIK="^YTD(601.2,",DA=DFN D IX^DIK ; reindex
  1. L -^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
  1. K YSQQ Q
  1. INTMP ; SAVE OLD
  1. M ^TMP($J,"YTAPI4")=^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)
  1. Q
  1. OUTTMP ;replace old testing
  1. M ^YTD(601.2,DFN,1,YSNCODE,1,YSADATE)=^TMP($J,"YTAPI4")
  1. Q
  1. NATSET(YSDATA,YS) ; set design environment to save fm entries <100,000
  1. ;entry point for YTQ SET NATIONAL rpc
  1. ;input: NATIONAL as Yes or No
  1. ;output: YSPROG=1
  1. N Y1
  1. I '$D(^XUSEC("YSPROG",DUZ)) S YSDATA(1)="[ERROR]",YSDATA(2)="no prog key" Q ;-->out
  1. S Y1=$G(YS("NATIONAL"))
  1. S Y1=$E(Y1,1)
  1. I (Y1'="Y")&(Y1'="N") S YSDATA(1)="[ERROR]",YSDATA(2)="no/BAD setting"
  1. S YSDATA(1)="[DATA]"
  1. I Y1="N" K YSPROG S YSDATA(2)="local editing set"
  1. I Y1="Y" S YSPROG=1,YSDATA(2)="national editing set"
  1. Q
  1. PATSEL(YSDATA,YS) ;patient component
  1. ;entry point for YTQ PATIENT INFO rpc
  1. ;input DFN as ien of file 2
  1. ;output
  1. ; YSDATA(2)= name
  1. ; YSDATA(3)=ssn
  1. ; YSDATA(4)=dob
  1. ; YSDATA(5)=age
  1. ; YSDATA(6)=sex
  1. ; YSDATA(7)=date of death (or 0)
  1. ; YSDATA(8)=0 NCS/ 1 SC^%^service connected
  1. N DFN,VADM,VAEL,VAERR
  1. S DFN=$G(YS("DFN"),-1)
  1. I '$D(^DPT(DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad dfn" Q ;-->out
  1. D 2^VADPT
  1. I VAERR=1 S YSDATA(1)="[ERROR]",YSDATA(2)="vadpt err" Q ;-->out
  1. S YSDATA(1)="[DATA]"
  1. S YSDATA(2)=VADM(1)_U_"name"
  1. S YSDATA(3)=VADM(2)_U_"ssn"
  1. S YSDATA(4)=VADM(3)_U_"dob"
  1. S YSDATA(5)=VADM(4)_U_"age"
  1. S YSDATA(6)=VADM(5)_U_"sex"
  1. S YSDATA(7)=+VADM(6)_U_$P(VADM(6),U,2)_U_"date of death"
  1. S YSDATA(8)=VAEL(3)_U_"service connected"
  1. Q
  1. USERQ(YSDATA,YS) ;user info
  1. ;entry point for YTQ USERQ rpc
  1. ;input DUZ as internal ien file 200 for user to check [optional default is current user]
  1. ; KEY as name of security key to check [optional]
  1. ; TITLE as name of Pnote [optional]
  1. ;output YSDATA(2)= name of user
  1. ; YSDATA(3) if key sent 1^holds VS 0^lacks KEY
  1. ; YSDATA(4) site info
  1. N K,YSKEY,YSDUZ,YSTITLE,DIC,YSCOS,N2,X
  1. S YSTITLE=$G(YS("TITLE"),-1)
  1. S YSDUZ=$G(YS("DUZ"),DUZ)
  1. S YSKEY=$G(YS("KEY"),-1)
  1. S YSTITLE=$G(YS("TITLE"))
  1. S YSDATA(1)="[DATA]"
  1. D OWNSKEY^XUSRB(.K,YSKEY,YSDUZ)
  1. S YSDATA(2)=$P($G(^VA(200,YSDUZ,0)),U)_U_YSDUZ
  1. I YSKEY=-1 S YSDATA(3)=""
  1. E S YSDATA(3)=$S(K(0):"1^holds ",1:"0^lacks ")_YSKEY
  1. S YSDATA(4)=$$SITE^VASITE_U_$$NAME^VASITE(DT)
  1. ;ASF 12/8/2009
  1. I YSTITLE="" S YSDATA(5)="^no title sent" Q ;-->out
  1. S Y=+$$DDEFIEN^TIUFLF7(YSTITLE,"TL")
  1. I +Y'>0 S YSDATA(5)="^bad pnote title" Q ;-->out
  1. D REQCOS^TIUSRVA(.YSCOS,+Y,"",YSDUZ) ;is cosigner required
  1. S YSDATA(5)=YSCOS_U_"cosigner "_$S(YSCOS=1:"required",YSCOS=0:"not required",1:"error")
  1. Q
  1. MHREPORT(YSDATA,YS) ;gets a report format from 601.93
  1. ;entry point for YTQ GET REPORT rpc
  1. ;Input: CODE as instrument name
  1. ;Output: LINE# ^ line text
  1. N N,N1,YSIENS,YSCODE,YSCODEN,YSIENS
  1. K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
  1. S ^TMP("YSDATA",$J,1)="[ERROR]"
  1. S YSCODE=$G(YS("CODE"),0)
  1. I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP("YSDATA",$J,2)="bad code" Q ;-->out
  1. S YSCODEN=$O(^YTT(601.71,"B",YSCODE,-1))
  1. S YSIENS=$O(^YTT(601.93,"C",YSCODEN,-1))
  1. I YSIENS'>0 S ^TMP("YSDATA",$J,1)="[DATA]^0" Q ;--> out
  1. S N=1,N1=0 F S N1=$O(^YTT(601.93,YSIENS,1,N1)) Q:N1'>0 D
  1. . S N=N+1,^TMP("YSDATA",$J,N)=$G(^YTT(601.93,YSIENS,1,N1,0))
  1. S ^TMP("YSDATA",$J,1)="[DATA]"_U_YSIENS
  1. Q