YTQAPI11 ;ASF/ALB - MHAx API ; 8/9/10 10:34am
;;5.01;MENTAL HEALTH;**85,96,123,187**;DEC 30,1994;Build 73
;
;Reference to %ZIS supported by IA #10086
;Reference to %ZTLOAD supported by IA #10063
;Reference to DOB^DPTLK1 supported by IA #3266
;Reference to SSN^DPTLK1 supported by IA #3267
SCORSAVE(YSDATA,YS) ;save results to 601.92
; input: AD as administration ID
; output: DATA vs ERROR
N YSAD,DIK,YSG,YSRNEW ; patch 123: don't need, removed tasking,Z,ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTDTH
; patch 123, new variables
N DA,Z
S YSAD=$G(YS("AD"))
I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q ;-->out
I '$D(^YTT(601.84,YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="ad not found" Q ;-->out
;
S YSDATA(1)="[DATA]"
;task
; patch 123 -- remove tasking call
;D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q ;-->out
;.S ZTIO="",ZTDTH=$H
;.S ZTRTN="SSEN^YTQAPI11",ZTDESC="MHA3 SCORSAVE",ZTSAVE("YS*")=""
;
SSEN ;scorsave entry
; patch 123 remove this, put in 2 other calls.
;D GETSCORE^YTQAPI8(.YSDATA,.YS)
; new subroutines
D LOADANSW^YTSCORE(.YSDATA,.YS) ; put Answers for an Admin into YSDATA
N IEN71
S IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
I 'IEN71 S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="No Instrument IEN in SCORSAVE" Q ;-->out
; design is in doScoring logic document
D SCOREINS^YTSCORE(.YSDATA,.IEN71) ; score the instrument passing Answer Array (YSDATA) and Instrument IEN
I $G(^TMP($J,"YSCOR",1))'="[DATA]" S ^TMP($J,"YSCOR",1)="[ERROR]",^TMP($J,"YSCOR",2)="Scoring Error, in SCORSAVE" Q ;-->out
D UPDSCORE^YTSCORE(.YSDATA,.YS)
Q
;delete any previous scores for this admin
; patch 123, original code, no longer deleting scores
;S DIK="^YTT(601.92,",DA=0
;F S DA=$O(^YTT(601.92,"AC",YSAD,DA)) Q:DA'>0 D ^DIK
;ADD SCORES
;S Z=1 F S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0 D
;. S YSG=^TMP($J,"YSCOR",Z)
;. S YSRNEW=$$NEW^YTQLIB(601.92)
;. S ^YTT(601.92,YSRNEW,0)=YSRNEW_U_YSAD_U_$P(YSG,"=")_U_$P(YSG,"=",2)
;. S DA=YSRNEW D IX^DIK
;S YSDATA(1)="[DATA]"
;Q
SCALES ;from copy
S YSSGOLD="" F S YSSGOLD=$O(^YTT(601.86,"AD",YSOLDNUM,YSSGOLD)) Q:YSSGOLD'>0 D
. S YSSGNEW=$$NEW^YTQLIB(601.86)
. S ^YTT(601.86,YSSGNEW,0)=^YTT(601.86,YSSGOLD,0)
. S $P(^YTT(601.86,YSSGNEW,0),U)=YSSGNEW
. S $P(^YTT(601.86,YSSGNEW,0),U,2)=YSNEWNUM
. S DA=YSSGNEW,DIK="^YTT(601.86," D IX^DIK
. S YSSLOLD=0 F S YSSLOLD=$O(^YTT(601.87,"AD",YSSGOLD,YSSLOLD)) Q:YSSLOLD'>0 D
.. S YSSLNEW=$$NEW^YTQLIB(601.87)
.. S ^YTT(601.87,YSSLNEW,0)=^YTT(601.87,YSSLOLD,0)
.. S $P(^YTT(601.87,YSSLNEW,0),U)=YSSLNEW
.. S $P(^YTT(601.87,YSSLNEW,0),U,2)=YSSGNEW
.. S DA=YSSLNEW,DIK="^YTT(601.87," D IX^DIK
.. S YSKEYOLD=0 F S YSKEYOLD=$O(^YTT(601.91,"AC",YSSLOLD,YSKEYOLD)) Q:YSKEYOLD'>0 D
... S YSKEYNEW=$$NEW^YTQLIB(601.91)
... S ^YTT(601.91,YSKEYNEW,0)=^YTT(601.91,YSKEYOLD,0)
... S $P(^YTT(601.91,YSKEYNEW,0),U)=YSKEYNEW
... S $P(^YTT(601.91,YSKEYNEW,0),U,2)=YSSLNEW
... S YSQX=$P(^YTT(601.91,YSKEYNEW,0),U,3)
... I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.91,YSKEYNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
... S DA=YSKEYNEW,DIK="^YTT(601.91," D IX^DIK
Q
RULES ;from copy
S N=$O(^YTT(601.83,"C",YSOLDNUM,N)) Q:N'>0 D
. S G1=^YTT(601.83,N,0)
. S YSISRNEW=$$NEW^YTQLIB(YSFILE)
. S ^YTT(601.83,YSISRNEW,0)=G1
. S $P(^YTT(601.83,YSISRNEW,0),U)=YSISRNEW
. S $P(^YTT(601.83,YSISRNEW,0),U,2)=YSNEWNUM
. S YSQX=$P(G1,U,3)
. I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.83,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
. S DA=YSISRNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
. ;add rule
. S YSRULOLD=$P(G,U,4)
. S G2=^YTT(601.82,YSRULOLD,0)
. S YSRULNEW=$$NEW^YTQLIB(601.82)
. S $P(^YTT(601.83,YSISRNEW,0),U,4)=YSRULNEW
. S ^YTT(601.82,YSRULNEW,0)=G2
. S $P(^YTT(601.82,YSRULNEW,0),U)=YSRULNEW
. S YSQX=$P(G2,U,2)
. I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,2)=^TMP($J,"YSM","O",YSQX)
. S YSQX=$P(G2,U,7)
. I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,7)=^TMP($J,"YSM","O",YSQX)
. S DA=YSRULNEW,DIK="^YTT(601.82," D IX^DIK
Q
FULLWP(YSDATA,YS) ;first line of all WPS
;returns a WP field
;Input: FILEN(file number), FIELD (WP filed #)
;Ouput IEN^WP Text line N
N N,YSN,YSN1,YSFILEN,YSFIELD
S YSDATA=$NA(^TMP($J,"YSWP")) K ^TMP($J,"YSWP")
S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD FILE N" Q ;--->out
S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD field" Q ;--> out
S YSN=0,N=1,^TMP($J,"YSWP",1)="[DATA]"
F S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0 D
. S YSN1=0 F S YSN1=$O(^YTT(YSFILEN,YSN,YSFIELD,YSN1)) Q:YSN1'>0 D
.. S N=N+1
.. S ^TMP($J,"YSWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,YSN1,0))
Q
FINDP(YSDATA,YS) ; patient lookup
; input:
; VALUE = value to lookup
; NUMBER= maximum number to find
; Lookup uses multiple index lookup of File #2
; output:
; [DATA]^number of records returned
; DFN^patient name^DOB^PID^Gender
;
N DIERR,YSVALUE,NODE,SSN,DSSN,PLID,YSN,YSX,YSNUMBER
S YSVALUE=$G(YS("VALUE"))
S YSNUMBER=$G(YS("NUMBER"),"*")
K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
D FIND^DIC(2,,".01;.03;.363;.09;.02","PS",YSVALUE,YSNUMBER,"B^BS^BS5^SSN")
I $G(DIERR) D CLEAN^DILF Q
S YSN=1,^TMP("YSDATA",$J,YSN)="[DATA]"_U_+^TMP("DILIST",$J,0)
S YSX=0 F S YSX=$O(^TMP("DILIST",$J,YSX)) Q:YSX'>0 D
. S NODE=^TMP("DILIST",$J,YSX,0)
. ;Apply DOB screen
. S $P(NODE,U,3)=$$DOB^DPTLK1(+NODE)
. ;Apply SSN screen
. S SSN=$$SSN^DPTLK1(+NODE)
. ;S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
. S DSSN="xxx-xx-"_$E(SSN,6,11)
. S PLID=$P(NODE,U,4)
. I $E(SSN,1,9)'?9N S (DSSN,PLID)=SSN
. S $P(NODE,U,4)=$S($L(PLID)>5:PLID,1:DSSN)
. ;Move screened data back into output global
. S YSN=YSN+1,^TMP("YSDATA",$J,YSN)=$P(NODE,U,1,4)_U_$P(NODE,U,6)
K ^TMP("DILIST",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI11 6025 printed Sep 23, 2025@19:54:12 Page 2
YTQAPI11 ;ASF/ALB - MHAx API ; 8/9/10 10:34am
+1 ;;5.01;MENTAL HEALTH;**85,96,123,187**;DEC 30,1994;Build 73
+2 ;
+3 ;Reference to %ZIS supported by IA #10086
+4 ;Reference to %ZTLOAD supported by IA #10063
+5 ;Reference to DOB^DPTLK1 supported by IA #3266
+6 ;Reference to SSN^DPTLK1 supported by IA #3267
SCORSAVE(YSDATA,YS) ;save results to 601.92
+1 ; input: AD as administration ID
+2 ; output: DATA vs ERROR
+3 ; patch 123: don't need, removed tasking,Z,ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTDTH
NEW YSAD,DIK,YSG,YSRNEW
+4 ; patch 123, new variables
+5 NEW DA,Z
+6 SET YSAD=$GET(YS("AD"))
+7 ;-->out
IF YSAD'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ad num"
QUIT
+8 ;-->out
IF '$DATA(^YTT(601.84,YSAD))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="ad not found"
QUIT
+9 ;
+10 SET YSDATA(1)="[DATA]"
+11 ;task
+12 ; patch 123 -- remove tasking call
+13 ;D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q ;-->out
+14 ;.S ZTIO="",ZTDTH=$H
+15 ;.S ZTRTN="SSEN^YTQAPI11",ZTDESC="MHA3 SCORSAVE",ZTSAVE("YS*")=""
+16 ;
SSEN ;scorsave entry
+1 ; patch 123 remove this, put in 2 other calls.
+2 ;D GETSCORE^YTQAPI8(.YSDATA,.YS)
+3 ; new subroutines
+4 ; put Answers for an Admin into YSDATA
DO LOADANSW^YTSCORE(.YSDATA,.YS)
+5 NEW IEN71
+6 SET IEN71=$$GET1^DIQ(601.84,YSAD_",",2,"I")
+7 ;-->out
IF 'IEN71
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="No Instrument IEN in SCORSAVE"
QUIT
+8 ; design is in doScoring logic document
+9 ; score the instrument passing Answer Array (YSDATA) and Instrument IEN
DO SCOREINS^YTSCORE(.YSDATA,.IEN71)
+10 ;-->out
IF $GET(^TMP($JOB,"YSCOR",1))'="[DATA]"
SET ^TMP($JOB,"YSCOR",1)="[ERROR]"
SET ^TMP($JOB,"YSCOR",2)="Scoring Error, in SCORSAVE"
QUIT
+11 DO UPDSCORE^YTSCORE(.YSDATA,.YS)
+12 QUIT
+13 ;delete any previous scores for this admin
+14 ; patch 123, original code, no longer deleting scores
+15 ;S DIK="^YTT(601.92,",DA=0
+16 ;F S DA=$O(^YTT(601.92,"AC",YSAD,DA)) Q:DA'>0 D ^DIK
+17 ;ADD SCORES
+18 ;S Z=1 F S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0 D
+19 ;. S YSG=^TMP($J,"YSCOR",Z)
+20 ;. S YSRNEW=$$NEW^YTQLIB(601.92)
+21 ;. S ^YTT(601.92,YSRNEW,0)=YSRNEW_U_YSAD_U_$P(YSG,"=")_U_$P(YSG,"=",2)
+22 ;. S DA=YSRNEW D IX^DIK
+23 ;S YSDATA(1)="[DATA]"
+24 ;Q
SCALES ;from copy
+1 SET YSSGOLD=""
FOR
SET YSSGOLD=$ORDER(^YTT(601.86,"AD",YSOLDNUM,YSSGOLD))
if YSSGOLD'>0
QUIT
Begin DoDot:1
+2 SET YSSGNEW=$$NEW^YTQLIB(601.86)
+3 SET ^YTT(601.86,YSSGNEW,0)=^YTT(601.86,YSSGOLD,0)
+4 SET $PIECE(^YTT(601.86,YSSGNEW,0),U)=YSSGNEW
+5 SET $PIECE(^YTT(601.86,YSSGNEW,0),U,2)=YSNEWNUM
+6 SET DA=YSSGNEW
SET DIK="^YTT(601.86,"
DO IX^DIK
+7 SET YSSLOLD=0
FOR
SET YSSLOLD=$ORDER(^YTT(601.87,"AD",YSSGOLD,YSSLOLD))
if YSSLOLD'>0
QUIT
Begin DoDot:2
+8 SET YSSLNEW=$$NEW^YTQLIB(601.87)
+9 SET ^YTT(601.87,YSSLNEW,0)=^YTT(601.87,YSSLOLD,0)
+10 SET $PIECE(^YTT(601.87,YSSLNEW,0),U)=YSSLNEW
+11 SET $PIECE(^YTT(601.87,YSSLNEW,0),U,2)=YSSGNEW
+12 SET DA=YSSLNEW
SET DIK="^YTT(601.87,"
DO IX^DIK
+13 SET YSKEYOLD=0
FOR
SET YSKEYOLD=$ORDER(^YTT(601.91,"AC",YSSLOLD,YSKEYOLD))
if YSKEYOLD'>0
QUIT
Begin DoDot:3
+14 SET YSKEYNEW=$$NEW^YTQLIB(601.91)
+15 SET ^YTT(601.91,YSKEYNEW,0)=^YTT(601.91,YSKEYOLD,0)
+16 SET $PIECE(^YTT(601.91,YSKEYNEW,0),U)=YSKEYNEW
+17 SET $PIECE(^YTT(601.91,YSKEYNEW,0),U,2)=YSSLNEW
+18 SET YSQX=$PIECE(^YTT(601.91,YSKEYNEW,0),U,3)
+19 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.91,YSKEYNEW,0),U,3)=^TMP($JOB,"YSM","O",YSQX)
+20 SET DA=YSKEYNEW
SET DIK="^YTT(601.91,"
DO IX^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
RULES ;from copy
+1 SET N=$ORDER(^YTT(601.83,"C",YSOLDNUM,N))
if N'>0
QUIT
Begin DoDot:1
+2 SET G1=^YTT(601.83,N,0)
+3 SET YSISRNEW=$$NEW^YTQLIB(YSFILE)
+4 SET ^YTT(601.83,YSISRNEW,0)=G1
+5 SET $PIECE(^YTT(601.83,YSISRNEW,0),U)=YSISRNEW
+6 SET $PIECE(^YTT(601.83,YSISRNEW,0),U,2)=YSNEWNUM
+7 SET YSQX=$PIECE(G1,U,3)
+8 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.83,YSECNEW,0),U,3)=^TMP($JOB,"YSM","O",YSQX)
+9 SET DA=YSISRNEW
SET DIK="^YTT("_YSFILE_","
DO IX^DIK
+10 ;add rule
+11 SET YSRULOLD=$PIECE(G,U,4)
+12 SET G2=^YTT(601.82,YSRULOLD,0)
+13 SET YSRULNEW=$$NEW^YTQLIB(601.82)
+14 SET $PIECE(^YTT(601.83,YSISRNEW,0),U,4)=YSRULNEW
+15 SET ^YTT(601.82,YSRULNEW,0)=G2
+16 SET $PIECE(^YTT(601.82,YSRULNEW,0),U)=YSRULNEW
+17 SET YSQX=$PIECE(G2,U,2)
+18 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.82,YSRULNEW,0),U,2)=^TMP($JOB,"YSM","O",YSQX)
+19 SET YSQX=$PIECE(G2,U,7)
+20 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.82,YSRULNEW,0),U,7)=^TMP($JOB,"YSM","O",YSQX)
+21 SET DA=YSRULNEW
SET DIK="^YTT(601.82,"
DO IX^DIK
End DoDot:1
+22 QUIT
FULLWP(YSDATA,YS) ;first line of all WPS
+1 ;returns a WP field
+2 ;Input: FILEN(file number), FIELD (WP filed #)
+3 ;Ouput IEN^WP Text line N
+4 NEW N,YSN,YSN1,YSFILEN,YSFIELD
+5 SET YSDATA=$NAME(^TMP($JOB,"YSWP"))
KILL ^TMP($JOB,"YSWP")
+6 ;--->out
SET YSFILEN=$GET(YS("FILEN"),0)
IF $$VFILE^DILFD(YSFILEN)<1
SET ^TMP($JOB,"YSWP",1)="[ERROR]"
SET ^TMP($JOB,"YSWP",2)="BAD FILE N"
QUIT
+7 ;--> out
SET YSFIELD=$GET(YS("FIELD"),0)
SET N=$$VFIELD^DILFD(YSFILEN,YSFIELD)
IF N<1
SET ^TMP($JOB,"YSWP",1)="[ERROR]"
SET ^TMP($JOB,"YSWP",2)="BAD field"
QUIT
+8 SET YSN=0
SET N=1
SET ^TMP($JOB,"YSWP",1)="[DATA]"
+9 FOR
SET YSN=$ORDER(^YTT(YSFILEN,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+10 SET YSN1=0
FOR
SET YSN1=$ORDER(^YTT(YSFILEN,YSN,YSFIELD,YSN1))
if YSN1'>0
QUIT
Begin DoDot:2
+11 SET N=N+1
+12 SET ^TMP($JOB,"YSWP",N)=YSN_U_$GET(^YTT(YSFILEN,YSN,YSFIELD,YSN1,0))
End DoDot:2
End DoDot:1
+13 QUIT
FINDP(YSDATA,YS) ; patient lookup
+1 ; input:
+2 ; VALUE = value to lookup
+3 ; NUMBER= maximum number to find
+4 ; Lookup uses multiple index lookup of File #2
+5 ; output:
+6 ; [DATA]^number of records returned
+7 ; DFN^patient name^DOB^PID^Gender
+8 ;
+9 NEW DIERR,YSVALUE,NODE,SSN,DSSN,PLID,YSN,YSX,YSNUMBER
+10 SET YSVALUE=$GET(YS("VALUE"))
+11 SET YSNUMBER=$GET(YS("NUMBER"),"*")
+12 KILL ^TMP("YSDATA",$JOB)
SET YSDATA=$NAME(^TMP("YSDATA",$JOB))
+13 DO FIND^DIC(2,,".01;.03;.363;.09;.02","PS",YSVALUE,YSNUMBER,"B^BS^BS5^SSN")
+14 IF $GET(DIERR)
DO CLEAN^DILF
QUIT
+15 SET YSN=1
SET ^TMP("YSDATA",$JOB,YSN)="[DATA]"_U_+^TMP("DILIST",$JOB,0)
+16 SET YSX=0
FOR
SET YSX=$ORDER(^TMP("DILIST",$JOB,YSX))
if YSX'>0
QUIT
Begin DoDot:1
+17 SET NODE=^TMP("DILIST",$JOB,YSX,0)
+18 ;Apply DOB screen
+19 SET $PIECE(NODE,U,3)=$$DOB^DPTLK1(+NODE)
+20 ;Apply SSN screen
+21 SET SSN=$$SSN^DPTLK1(+NODE)
+22 ;S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
+23 SET DSSN="xxx-xx-"_$EXTRACT(SSN,6,11)
+24 SET PLID=$PIECE(NODE,U,4)
+25 IF $EXTRACT(SSN,1,9)'?9N
SET (DSSN,PLID)=SSN
+26 SET $PIECE(NODE,U,4)=$SELECT($LENGTH(PLID)>5:PLID,1:DSSN)
+27 ;Move screened data back into output global
+28 SET YSN=YSN+1
SET ^TMP("YSDATA",$JOB,YSN)=$PIECE(NODE,U,1,4)_U_$PIECE(NODE,U,6)
End DoDot:1
+29 KILL ^TMP("DILIST",$JOB)
+30 QUIT
