YSDSS ;DALCIOFO/MJD-MENTAL HEALTH DSS EXTRACT ;05/19/99
;;5.01;MENTAL HEALTH;**56**;Dec 30, 1994
Q
;
UPD(YSFILE,YSFRN,YSYRMO,YSEXTN,YSSITE,YSSD,YSEND,YSERR) ;parameter list
;
; YSFILE - MENTAL HEALTH EXTRACT file (#727.812) - constant
; YSFRN - Last IEN of the MENTAL HEALTH EXTRACT file (#727.812)
; YSYRMO - YearMonth of the extract to which this record belongs
; YSEXTN - Identifies the specific extract to which this record belongs
; YSSITE - Facility number
; YSSD - Start date for extract
; YSEND - End date for extract
; YSERR - for return of "1", if error condition; otherwise return "0";
; passed by reference; if any parameter missing or incorrect
; format, then return "1"
;
;
; Check for DSS MH TESTS file (#727.5)
I '$D(^ECX(727.5,0)) S YSERR=1 Q
; Check for YTAPI2 routine
S X="YTAPI2" X ^%ZOSF("TEST") I '$T S YSERR=1 Q
;
D PT
D ASI
D GAF
Q
;
PT ; Retrieve the PSYCH INSTRUMENT PATIENT file (#601.2) data
N YSD,YSD2,YSDFN,YSTSTN
S YSDFN=0
F S YSDFN=$O(^YTD(601.2,YSDFN)) Q:YSDFN=""!('YSDFN) D
.Q:$$TEST(YSDFN)
. S YSD=0
. F S YSD=$O(^YTD(601.2,YSDFN,1,YSD)) Q:'YSD D
.. S YSTSTN=$P($G(^YTT(601,+YSD,0)),U)
.. Q:YSTSTN=""
.. S YSD2=0
.. F S YSD2=$O(^YTD(601.2,YSDFN,1,YSD,1,YSD2)) Q:'YSD2 D
... Q:(YSD2<(YSSD)) Q:(YSD2>(YSEND+1))
... S YSDET=0 D CHKT
... I YSDET D
.... S YS("DFN")=YSDFN
.... S YS("CODE")=YSTSTN
.... S YS("ADATE")=$$FMTE^XLFDT(YSD2,"2DZ")
.... D SCOREIT^YTAPI2(.YSDATA,.YS)
.... S YSPRV=$P(^YTD(601.2,YSDFN,1,YSD,1,YSD2,0),U,3)
.... S YSSCOR=""
.... S YSS=5
.... F S YSS=$O(YSDATA(YSS)) Q:YSS'>0 D
..... S YSSCNUM=$P(YSDATA(YSS),U)
..... S YSSCNAM=$P(YSDATA(YSS),U,2)
..... S YSSCSC=$P(YSDATA(YSS),U,3)
..... D CR
..... Q
... I 'YSDET D
.... S (YSPRV,YSSCNUM,YSSCNAM,YSSCOR,YSSCSC)=""
.... D CR
.... Q
... Q
.. Q
.Q
Q
;
CHKT ;
N YS,YSACT,YSINACT
S (YS,YSDET)=0,(YSACT,YSINACT)=""
Q:'$D(^ECX(727.5,"B",YSTSTN))
S YS=$O(^ECX(727.5,"B",YSTSTN,YS))
Q:'$D(^ECX(727.5,YS,0))
S YSACT=$O(^ECX(727.5,"AC",YS,9999999),-1)
I $D(^ECX(727.5,"AX",YS)) S YSINACT=$O(^ECX(727.5,"AX",YS,9999999),-1)
Q:YSACT>YSD2
Q:YSINACT>YSACT
S YSDET=1
Q
;
CR ;Create a MENTAL HEALTH EXTRACT
S YSFRN=YSFRN+1
S ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
S $P(^ECX(YSFILE,YSFRN,0),U,9)=YSD2
S $P(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
S $P(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
S $P(^ECX(YSFILE,YSFRN,0),U,22)=YSD
S $P(^ECX(YSFILE,YSFRN,0),U,23)=YSSCNUM
S $P(^ECX(YSFILE,YSFRN,0),U,24)=YSSCNAM
S $P(^ECX(YSFILE,YSFRN,0),U,25)=YSSCOR
S $P(^ECX(YSFILE,YSFRN,0),U,26)=YSSCSC
QUIT
;
ASI ; ASI
N YSDFN,YSIEN,YSASIDT
S YSTSTN="ASI"
S YSDFN=0
F S YSDFN=$O(^YSTX(604,"C",YSDFN)) Q:'YSDFN D
.Q:$$TEST(YSDFN)
. S YSIEN=0
. F S YSIEN=$O(^YSTX(604,"C",YSDFN,YSIEN)) Q:'YSIEN D
.. Q:'$D(^YSTX(604,YSIEN,0))
.. S YSASIDT=$P($P(^YSTX(604,YSIEN,0),"^",5),".",1)
.. I (YSASIDT>(YSSD-1))&(YSASIDT<(YSEND+1)) D
... S YSDTOI=$P(^YSTX(604,YSIEN,0),U,5)
... S YSPRV=$P(^YSTX(604,YSIEN,0),U,9)
... S YS("DFN")=YSDFN
... S YS("CODE")="ASI"
... S YSCLAS=$P(^YSTX(604,YSIEN,0),U,4)
... S YSSPEC=$P(^YSTX(604,YSIEN,0),U,11)
... S YS("ADATE")=$$FMTE^XLFDT(YSASIDT,"2DZ")
... D SCOREIT^YTAPI2(.YSDATA,.YS)
... F YSS=6:1 Q:YSS>12 D CRASI
... Q
.. Q
. Q
Q
;
CRASI ;
S YSFRN=YSFRN+1
S YSSCNUM=$P(YSDATA(YSS),U)
S YSSCNAM=$P(YSDATA(YSS),U,2)
S YSSCSC=$TR($P(YSDATA(YSS),U,4)," ")
S ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
S $P(^ECX(YSFILE,YSFRN,0),U,9)=YSDTOI
S $P(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
S $P(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
S $P(^ECX(YSFILE,YSFRN,0),U,23)=YSSCNUM
S $P(^ECX(YSFILE,YSFRN,0),U,24)=YSSCNAM
S $P(^ECX(YSFILE,YSFRN,0),U,26)=YSSCSC
S ^ECX(YSFILE,YSFRN,1)=""
S $P(^ECX(YSFILE,YSFRN,1),U,5)=YSCLAS
S $P(^ECX(YSFILE,YSFRN,1),U,6)=YSSPEC
QUIT
;
GAF ; GAF
N YSIEN
S YSIEN=0
F S YSIEN=$O(^YSD(627.8,YSIEN)) Q:YSIEN=""!('YSIEN) D
. Q:'$D(^YSD(627.8,YSIEN,0))
. S YSGFDATE=$P($P(^YSD(627.8,YSIEN,0),"^",3),".",1)
. I (YSGFDATE>(YSSD-1))&(YSGFDATE<(YSEND+1)) D
.. I $P($G(^YSD(627.8,YSIEN,60)),U,3)="" Q
.. S YSDFN=$P(^YSD(627.8,YSIEN,0),U,2)
.. Q:$$TEST(YSDFN)
.. S YSFRN=YSFRN+1
.. S YSPRV=$P(^YSD(627.8,YSIEN,0),U,4)
.. S YSTSTN="GAF"
.. S YSSCOR=$P($G(^YSD(627.8,YSIEN,60)),U,3)
.. S ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
.. S $P(^ECX(YSFILE,YSFRN,0),U,9)=YSGFDATE
.. S $P(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
.. S $P(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
.. S $P(^ECX(YSFILE,YSFRN,0),U,25)=YSSCOR
.. Q
. Q
QUIT
;
TEST(YSDFN) ;is this a test patient?
N ARR,SSN
S DA=YSDFN,DIC="^DPT(",DIQ(0)="I",DR=".09",DIQ="ARR"
D EN^DIQ1
S SSN=ARR(2,YSDFN,.09,"I")
I $E(SSN,1,5)="00000" Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDSS 4872 printed Sep 23, 2025@19:50:18 Page 2
YSDSS ;DALCIOFO/MJD-MENTAL HEALTH DSS EXTRACT ;05/19/99
+1 ;;5.01;MENTAL HEALTH;**56**;Dec 30, 1994
+2 QUIT
+3 ;
UPD(YSFILE,YSFRN,YSYRMO,YSEXTN,YSSITE,YSSD,YSEND,YSERR) ;parameter list
+1 ;
+2 ; YSFILE - MENTAL HEALTH EXTRACT file (#727.812) - constant
+3 ; YSFRN - Last IEN of the MENTAL HEALTH EXTRACT file (#727.812)
+4 ; YSYRMO - YearMonth of the extract to which this record belongs
+5 ; YSEXTN - Identifies the specific extract to which this record belongs
+6 ; YSSITE - Facility number
+7 ; YSSD - Start date for extract
+8 ; YSEND - End date for extract
+9 ; YSERR - for return of "1", if error condition; otherwise return "0";
+10 ; passed by reference; if any parameter missing or incorrect
+11 ; format, then return "1"
+12 ;
+13 ;
+14 ; Check for DSS MH TESTS file (#727.5)
+15 IF '$DATA(^ECX(727.5,0))
SET YSERR=1
QUIT
+16 ; Check for YTAPI2 routine
+17 SET X="YTAPI2"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET YSERR=1
QUIT
+18 ;
+19 DO PT
+20 DO ASI
+21 DO GAF
+22 QUIT
+23 ;
PT ; Retrieve the PSYCH INSTRUMENT PATIENT file (#601.2) data
+1 NEW YSD,YSD2,YSDFN,YSTSTN
+2 SET YSDFN=0
+3 FOR
SET YSDFN=$ORDER(^YTD(601.2,YSDFN))
if YSDFN=""!('YSDFN)
QUIT
Begin DoDot:1
+4 if $$TEST(YSDFN)
QUIT
+5 SET YSD=0
+6 FOR
SET YSD=$ORDER(^YTD(601.2,YSDFN,1,YSD))
if 'YSD
QUIT
Begin DoDot:2
+7 SET YSTSTN=$PIECE($GET(^YTT(601,+YSD,0)),U)
+8 if YSTSTN=""
QUIT
+9 SET YSD2=0
+10 FOR
SET YSD2=$ORDER(^YTD(601.2,YSDFN,1,YSD,1,YSD2))
if 'YSD2
QUIT
Begin DoDot:3
+11 if (YSD2<(YSSD))
QUIT
if (YSD2>(YSEND+1))
QUIT
+12 SET YSDET=0
DO CHKT
+13 IF YSDET
Begin DoDot:4
+14 SET YS("DFN")=YSDFN
+15 SET YS("CODE")=YSTSTN
+16 SET YS("ADATE")=$$FMTE^XLFDT(YSD2,"2DZ")
+17 DO SCOREIT^YTAPI2(.YSDATA,.YS)
+18 SET YSPRV=$PIECE(^YTD(601.2,YSDFN,1,YSD,1,YSD2,0),U,3)
+19 SET YSSCOR=""
+20 SET YSS=5
+21 FOR
SET YSS=$ORDER(YSDATA(YSS))
if YSS'>0
QUIT
Begin DoDot:5
+22 SET YSSCNUM=$PIECE(YSDATA(YSS),U)
+23 SET YSSCNAM=$PIECE(YSDATA(YSS),U,2)
+24 SET YSSCSC=$PIECE(YSDATA(YSS),U,3)
+25 DO CR
+26 QUIT
End DoDot:5
End DoDot:4
+27 IF 'YSDET
Begin DoDot:4
+28 SET (YSPRV,YSSCNUM,YSSCNAM,YSSCOR,YSSCSC)=""
+29 DO CR
+30 QUIT
End DoDot:4
+31 QUIT
End DoDot:3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 QUIT
+35 ;
CHKT ;
+1 NEW YS,YSACT,YSINACT
+2 SET (YS,YSDET)=0
SET (YSACT,YSINACT)=""
+3 if '$DATA(^ECX(727.5,"B",YSTSTN))
QUIT
+4 SET YS=$ORDER(^ECX(727.5,"B",YSTSTN,YS))
+5 if '$DATA(^ECX(727.5,YS,0))
QUIT
+6 SET YSACT=$ORDER(^ECX(727.5,"AC",YS,9999999),-1)
+7 IF $DATA(^ECX(727.5,"AX",YS))
SET YSINACT=$ORDER(^ECX(727.5,"AX",YS,9999999),-1)
+8 if YSACT>YSD2
QUIT
+9 if YSINACT>YSACT
QUIT
+10 SET YSDET=1
+11 QUIT
+12 ;
CR ;Create a MENTAL HEALTH EXTRACT
+1 SET YSFRN=YSFRN+1
+2 SET ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
+3 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,9)=YSD2
+4 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
+5 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
+6 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,22)=YSD
+7 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,23)=YSSCNUM
+8 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,24)=YSSCNAM
+9 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,25)=YSSCOR
+10 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,26)=YSSCSC
+11 QUIT
+12 ;
ASI ; ASI
+1 NEW YSDFN,YSIEN,YSASIDT
+2 SET YSTSTN="ASI"
+3 SET YSDFN=0
+4 FOR
SET YSDFN=$ORDER(^YSTX(604,"C",YSDFN))
if 'YSDFN
QUIT
Begin DoDot:1
+5 if $$TEST(YSDFN)
QUIT
+6 SET YSIEN=0
+7 FOR
SET YSIEN=$ORDER(^YSTX(604,"C",YSDFN,YSIEN))
if 'YSIEN
QUIT
Begin DoDot:2
+8 if '$DATA(^YSTX(604,YSIEN,0))
QUIT
+9 SET YSASIDT=$PIECE($PIECE(^YSTX(604,YSIEN,0),"^",5),".",1)
+10 IF (YSASIDT>(YSSD-1))&(YSASIDT<(YSEND+1))
Begin DoDot:3
+11 SET YSDTOI=$PIECE(^YSTX(604,YSIEN,0),U,5)
+12 SET YSPRV=$PIECE(^YSTX(604,YSIEN,0),U,9)
+13 SET YS("DFN")=YSDFN
+14 SET YS("CODE")="ASI"
+15 SET YSCLAS=$PIECE(^YSTX(604,YSIEN,0),U,4)
+16 SET YSSPEC=$PIECE(^YSTX(604,YSIEN,0),U,11)
+17 SET YS("ADATE")=$$FMTE^XLFDT(YSASIDT,"2DZ")
+18 DO SCOREIT^YTAPI2(.YSDATA,.YS)
+19 FOR YSS=6:1
if YSS>12
QUIT
DO CRASI
+20 QUIT
End DoDot:3
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
CRASI ;
+1 SET YSFRN=YSFRN+1
+2 SET YSSCNUM=$PIECE(YSDATA(YSS),U)
+3 SET YSSCNAM=$PIECE(YSDATA(YSS),U,2)
+4 SET YSSCSC=$TRANSLATE($PIECE(YSDATA(YSS),U,4)," ")
+5 SET ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
+6 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,9)=YSDTOI
+7 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
+8 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
+9 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,23)=YSSCNUM
+10 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,24)=YSSCNAM
+11 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,26)=YSSCSC
+12 SET ^ECX(YSFILE,YSFRN,1)=""
+13 SET $PIECE(^ECX(YSFILE,YSFRN,1),U,5)=YSCLAS
+14 SET $PIECE(^ECX(YSFILE,YSFRN,1),U,6)=YSSPEC
+15 QUIT
+16 ;
GAF ; GAF
+1 NEW YSIEN
+2 SET YSIEN=0
+3 FOR
SET YSIEN=$ORDER(^YSD(627.8,YSIEN))
if YSIEN=""!('YSIEN)
QUIT
Begin DoDot:1
+4 if '$DATA(^YSD(627.8,YSIEN,0))
QUIT
+5 SET YSGFDATE=$PIECE($PIECE(^YSD(627.8,YSIEN,0),"^",3),".",1)
+6 IF (YSGFDATE>(YSSD-1))&(YSGFDATE<(YSEND+1))
Begin DoDot:2
+7 IF $PIECE($GET(^YSD(627.8,YSIEN,60)),U,3)=""
QUIT
+8 SET YSDFN=$PIECE(^YSD(627.8,YSIEN,0),U,2)
+9 if $$TEST(YSDFN)
QUIT
+10 SET YSFRN=YSFRN+1
+11 SET YSPRV=$PIECE(^YSD(627.8,YSIEN,0),U,4)
+12 SET YSTSTN="GAF"
+13 SET YSSCOR=$PIECE($GET(^YSD(627.8,YSIEN,60)),U,3)
+14 SET ^ECX(YSFILE,YSFRN,0)=YSFRN_U_YSYRMO_U_YSEXTN_U_YSSITE_U_YSDFN
+15 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,9)=YSGFDATE
+16 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,18)=YSPRV
+17 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,21)=YSTSTN
+18 SET $PIECE(^ECX(YSFILE,YSFRN,0),U,25)=YSSCOR
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
TEST(YSDFN) ;is this a test patient?
+1 NEW ARR,SSN
+2 SET DA=YSDFN
SET DIC="^DPT("
SET DIQ(0)="I"
SET DR=".09"
SET DIQ="ARR"
+3 DO EN^DIQ1
+4 SET SSN=ARR(2,YSDFN,.09,"I")
+5 IF $EXTRACT(SSN,1,5)="00000"
QUIT 1
+6 QUIT 0
