YS105PRE ;HIOFO/FT - YS*5.01*105 PRE-INIT ; 7/1/13 11:37am
;;5.01;MENTAL HEALTH;**105**;Dec 30, 1994;Build 76
;
;Reference to XPDGREF and ^XTMP supported by DBIA #2433
;
MAIN ;Main entry
D EN1,EN2,EN2A,EN3,EN4
Q
EN1 ;MH CHOICES (601.75)
;Delete CHOICE TEXT (field #3).
;CHOICE TEXT which is an IDENTIFIER has changed.
;The KIDS build will add the correct value.
N YSARR,YSFDA,YSIEN
F YSIEN=1192,1251,1261,1348,1457,2305,2472,2885,2914,3194,3196,3267,3268,3319:1:3325,3327,3328,3339:1:3341,3343:1:3345,3352,3394,3440,3441,3519,3528 D
.S YSFDA(601.75,YSIEN_",",3)="@"
.D UPDATE^DIE("","YSFDA","YSARR")
.K YSARR,YSFDA
Q
EN2 ;MH SCALEGROUPS (601.86)
;Modify SCALEGROUP NAME field (#2).
;SCALEGROUP NAME which is an IDENTIFIER has changed.
N YSARR,YSFDA
S YSFDA(601.86,"50,",2)="Management Guides"
D UPDATE^DIE("","YSFDA","YSARR")
K YSARR,YSFDA
S YSFDA(601.86,"68,",2)="BHS Score"
D UPDATE^DIE("","YSFDA","YSARR")
K YSARR,YSFDA
S YSFDA(601.86,"69,",2)="BSI Total"
D UPDATE^DIE("","YSFDA","YSARR")
Q
EN2A ;MH SCALES (601.87)
;Modify SCALE NAME field (#3).
;SCALE NAME which is an IDENTIFIER has changed.
N YSARR,YSFDA
S YSFDA(601.87,"883,",3)="@"
D UPDATE^DIE("","YSFDA","YSARR")
Q
EN3 ;Edit MH INSTRUMENT (601)
I ^YTT(601,241,"Q",9,"T",1,0)="LOSS OF INTEREST in activities that you used to enjoy?" D
.S ^YTT(601,241,"Q",9,"T",1,0)="LOSS of INTEREST in activities that you used to enjoy?"
I ^YTT(601,241,"Q",10,"T",1,0)="Feeling DISTANT OR CUT OFF from other people?" D
.S ^YTT(601,241,"Q",10,"T",1,0)="Feeling DISTANT or CUT OFF from other people?"
I ^YTT(601,242,"Q",9,"T",1,0)="LOSS OF INTEREST in activities that you used to enjoy?" D
.S ^YTT(601,242,"Q",9,"T",1,0)="LOSS of INTEREST in activities that you used to enjoy?"
I ^YTT(601,242,"Q",10,"T",1,0)="Feeling DISTANT OR CUT OFF from other people?" D
.S ^YTT(601,242,"Q",10,"T",1,0)="Feeling DISTANT or CUT OFF from other people?"
Q
EN4 ;ensure instrument names & iens match
N YSIEN,YSLINE,YSNAME,YSTEXT
F YSLINE=1:1 S YSTEXT=$T(NAME+YSLINE) Q:$P(YSTEXT,";",3)="" D
.S YSIEN=$P(YSTEXT,";",3),YSNAME=$P(YSTEXT,";",4)
.D EN4B(YSIEN,YSNAME)
.I $P($G(^YTT(601.71,YSIEN,0)),U,1)=YSNAME Q
.I '$D(^YTT(601.71,YSIEN,0)) D EN4A(YSIEN,YSNAME) Q
.D EN4C(YSIEN,YSNAME)
Q
EN4A(YSX,YSY) ;add instrument zero node & B x-ref placeholders
Q:$G(YSX)'>0
Q:$G(YSY)=""
S $P(^YTT(601.71,YSX,0),U,1)=YSY
S ^YTT(601.71,"B",YSY,YSX)=""
Q
EN4B(YSX,YSY) ;rename instrument to avoid duplicates
N YSARR,YSDA,YSFDA,YSTEXT
Q:$G(YSX)'>0
Q:$G(YSY)=""
S YSDA=0
F S YSDA=$O(^YTT(601.71,"B",YSY,YSDA)) Q:'YSDA D
.Q:YSDA=YSX
.S YSTEXT="ZZ"_$P($G(^YTT(601.71,YSDA,0)),U,1)
.S YSFDA(601.71,YSDA_",",.01)=YSTEXT
.S YSFDA(601.71,YSDA_",",10)="N"
.D UPDATE^DIE("","YSFDA","YSARR")
Q
EN4C(YSX,YSY) ;change instrument name
N YSARR,YSFDA
Q:$G(YSX)'>0
Q:$G(YSY)=""
S YSFDA(601.71,YSX_",",.01)=YSY
D UPDATE^DIE("","YSFDA","YSARR")
Q
NAME ;;601.71 IEN;601.71 .01 VALUE
;;170;AAQ-2
;;189;BAM-C
;;191;BAM-IOP
;;190;BAM-R
;;180;BARTHEL INDEX
;;171;FFMQ
;;173;GPCOG
;;168;IADL
;;29;MBMD
;;78;MHLC-C
;;174;MINICOG
;;187;MMPI-2-RF
;;175;MOCA
;;178;MOCA ALT 1
;;179;MOCA ALT 2
;;182;NEO-PI-3
;;149;PCLS
;;169;PHQ-15
;;188;QOLI
;;185;SSF
;;176;STMS
;;177;VR-12
;;183;VRA
;;181;WHODAS 2
;;166;PCL-SZ
;;37;MMP2S
;;30;MCMI2
;;102;BRS
;;142;CEMI
;;143;SNQ
;;144;CSI
;;145;FAD
;;146;IMRA
;;147;FOCI
;;148;PCL-5
;;150;SST-VOI
;;151;SST-VOF
;;167;KATZ ADL
;;192;STOP
;;193;MDQ
;;194;CAM
;;195;PSOCQ
;;196;PSS
;;197;DBAS
;;198;WHOQOL-BREF
;;199;ISI
;;201;RLS
;;203;QOLIE-10
;;205;SOCRATES 8A
;;206;SOCRATES 8D
;;207;ASSIST NIDA
;;208;BSL-23
;;209;DERS
;;210;KTZADL
;;211;YBOCSII
;;212;YBOCSII SYMPTOM LIST
;;213;SIP-2L
;;214;QOLIE-31
;;215;CCSA-DSM5
;;216;SMEQ
;;217;AAQ-SA
;;218;CIWA-AR-
;;;
Q
PRETRAN ;Pre-Transportation entry point
;Copy the MH CHOICETYPE (601.751) entries into the transport global
N YSLOOP
S YSLOOP=0
F S YSLOOP=$O(^YTT(601.751,YSLOOP)) Q:'YSLOOP!(YSLOOP>99999) D
.S @XPDGREF@(601.751,YSLOOP)=$G(^YTT(601.751,YSLOOP,0))
Q
POST751 ;enter all MH CHOICETYPE (601.751) entries
N N,DIK
S N=0
F S N=$O(^XTMP("XPDI",XPDA,"TEMP",601.751,N)) Q:N'>0 D
.S ^YTT(601.751,N,0)=^XTMP("XPDI",XPDA,"TEMP",601.751,N)
S DIK="^YTT(601.751," D IXALL^DIK
;Kill existing indexes and re-index
K ^YTT(601.76,"B"),^YTT(601.76,"AC"),^YTT(601.76,"AE"),^YTT(601.76,"AD"),^YTT(601.76,"AF")
S DIK="^YTT(601.76," D IXALL^DIK
K ^YTT(601.71,"B")
S DIK="^YTT(601.71," D IXALL^DIK
K ^YTT(601.79,"B"),^YTT(601.79,"AC"),^YTT(601.79,"AD"),^YTT(601.79,"AE"),^YTT(601.79,"AF")
S DIK="^YTT(601.79," D IXALL^DIK
K ^YTT(601.81,"B"),^YTT(601.81,"AC")
S DIK="^YTT(601.81," D IXALL^DIK
K ^YTT(601.83,"B"),^YTT(601.83,"AC"),^YTT(601.83,"C"),^YTT(601.83,"AD")
S DIK="^YTT(601.83," D IXALL^DIK
K ^YTT(601.86,"B"),^YTT(601.86,"AC"),^YTT(601.86,"AD")
S DIK="^YTT(601.86," D IXALL^DIK
K ^YTT(601.93,"B"),^YTT(601.93,"C")
S DIK="^YTT(601.93," D IXALL^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS105PRE 5160 printed Sep 23, 2025@19:48:02 Page 2
YS105PRE ;HIOFO/FT - YS*5.01*105 PRE-INIT ; 7/1/13 11:37am
+1 ;;5.01;MENTAL HEALTH;**105**;Dec 30, 1994;Build 76
+2 ;
+3 ;Reference to XPDGREF and ^XTMP supported by DBIA #2433
+4 ;
MAIN ;Main entry
+1 DO EN1
DO EN2
DO EN2A
DO EN3
DO EN4
+2 QUIT
EN1 ;MH CHOICES (601.75)
+1 ;Delete CHOICE TEXT (field #3).
+2 ;CHOICE TEXT which is an IDENTIFIER has changed.
+3 ;The KIDS build will add the correct value.
+4 NEW YSARR,YSFDA,YSIEN
+5 FOR YSIEN=1192,1251,1261,1348,1457,2305,2472,2885,2914,3194,3196,3267,3268,3319:1:3325,3327,3328,3339:1:3341,3343:1:3345,3352,3394,3440,3441,3519,3528
Begin DoDot:1
+6 SET YSFDA(601.75,YSIEN_",",3)="@"
+7 DO UPDATE^DIE("","YSFDA","YSARR")
+8 KILL YSARR,YSFDA
End DoDot:1
+9 QUIT
EN2 ;MH SCALEGROUPS (601.86)
+1 ;Modify SCALEGROUP NAME field (#2).
+2 ;SCALEGROUP NAME which is an IDENTIFIER has changed.
+3 NEW YSARR,YSFDA
+4 SET YSFDA(601.86,"50,",2)="Management Guides"
+5 DO UPDATE^DIE("","YSFDA","YSARR")
+6 KILL YSARR,YSFDA
+7 SET YSFDA(601.86,"68,",2)="BHS Score"
+8 DO UPDATE^DIE("","YSFDA","YSARR")
+9 KILL YSARR,YSFDA
+10 SET YSFDA(601.86,"69,",2)="BSI Total"
+11 DO UPDATE^DIE("","YSFDA","YSARR")
+12 QUIT
EN2A ;MH SCALES (601.87)
+1 ;Modify SCALE NAME field (#3).
+2 ;SCALE NAME which is an IDENTIFIER has changed.
+3 NEW YSARR,YSFDA
+4 SET YSFDA(601.87,"883,",3)="@"
+5 DO UPDATE^DIE("","YSFDA","YSARR")
+6 QUIT
EN3 ;Edit MH INSTRUMENT (601)
+1 IF ^YTT(601,241,"Q",9,"T",1,0)="LOSS OF INTEREST in activities that you used to enjoy?"
Begin DoDot:1
+2 SET ^YTT(601,241,"Q",9,"T",1,0)="LOSS of INTEREST in activities that you used to enjoy?"
End DoDot:1
+3 IF ^YTT(601,241,"Q",10,"T",1,0)="Feeling DISTANT OR CUT OFF from other people?"
Begin DoDot:1
+4 SET ^YTT(601,241,"Q",10,"T",1,0)="Feeling DISTANT or CUT OFF from other people?"
End DoDot:1
+5 IF ^YTT(601,242,"Q",9,"T",1,0)="LOSS OF INTEREST in activities that you used to enjoy?"
Begin DoDot:1
+6 SET ^YTT(601,242,"Q",9,"T",1,0)="LOSS of INTEREST in activities that you used to enjoy?"
End DoDot:1
+7 IF ^YTT(601,242,"Q",10,"T",1,0)="Feeling DISTANT OR CUT OFF from other people?"
Begin DoDot:1
+8 SET ^YTT(601,242,"Q",10,"T",1,0)="Feeling DISTANT or CUT OFF from other people?"
End DoDot:1
+9 QUIT
EN4 ;ensure instrument names & iens match
+1 NEW YSIEN,YSLINE,YSNAME,YSTEXT
+2 FOR YSLINE=1:1
SET YSTEXT=$TEXT(NAME+YSLINE)
if $PIECE(YSTEXT,";",3)=""
QUIT
Begin DoDot:1
+3 SET YSIEN=$PIECE(YSTEXT,";",3)
SET YSNAME=$PIECE(YSTEXT,";",4)
+4 DO EN4B(YSIEN,YSNAME)
+5 IF $PIECE($GET(^YTT(601.71,YSIEN,0)),U,1)=YSNAME
QUIT
+6 IF '$DATA(^YTT(601.71,YSIEN,0))
DO EN4A(YSIEN,YSNAME)
QUIT
+7 DO EN4C(YSIEN,YSNAME)
End DoDot:1
+8 QUIT
EN4A(YSX,YSY) ;add instrument zero node & B x-ref placeholders
+1 if $GET(YSX)'>0
QUIT
+2 if $GET(YSY)=""
QUIT
+3 SET $PIECE(^YTT(601.71,YSX,0),U,1)=YSY
+4 SET ^YTT(601.71,"B",YSY,YSX)=""
+5 QUIT
EN4B(YSX,YSY) ;rename instrument to avoid duplicates
+1 NEW YSARR,YSDA,YSFDA,YSTEXT
+2 if $GET(YSX)'>0
QUIT
+3 if $GET(YSY)=""
QUIT
+4 SET YSDA=0
+5 FOR
SET YSDA=$ORDER(^YTT(601.71,"B",YSY,YSDA))
if 'YSDA
QUIT
Begin DoDot:1
+6 if YSDA=YSX
QUIT
+7 SET YSTEXT="ZZ"_$PIECE($GET(^YTT(601.71,YSDA,0)),U,1)
+8 SET YSFDA(601.71,YSDA_",",.01)=YSTEXT
+9 SET YSFDA(601.71,YSDA_",",10)="N"
+10 DO UPDATE^DIE("","YSFDA","YSARR")
End DoDot:1
+11 QUIT
EN4C(YSX,YSY) ;change instrument name
+1 NEW YSARR,YSFDA
+2 if $GET(YSX)'>0
QUIT
+3 if $GET(YSY)=""
QUIT
+4 SET YSFDA(601.71,YSX_",",.01)=YSY
+5 DO UPDATE^DIE("","YSFDA","YSARR")
+6 QUIT
NAME ;;601.71 IEN;601.71 .01 VALUE
+1 ;;170;AAQ-2
+2 ;;189;BAM-C
+3 ;;191;BAM-IOP
+4 ;;190;BAM-R
+5 ;;180;BARTHEL INDEX
+6 ;;171;FFMQ
+7 ;;173;GPCOG
+8 ;;168;IADL
+9 ;;29;MBMD
+10 ;;78;MHLC-C
+11 ;;174;MINICOG
+12 ;;187;MMPI-2-RF
+13 ;;175;MOCA
+14 ;;178;MOCA ALT 1
+15 ;;179;MOCA ALT 2
+16 ;;182;NEO-PI-3
+17 ;;149;PCLS
+18 ;;169;PHQ-15
+19 ;;188;QOLI
+20 ;;185;SSF
+21 ;;176;STMS
+22 ;;177;VR-12
+23 ;;183;VRA
+24 ;;181;WHODAS 2
+25 ;;166;PCL-SZ
+26 ;;37;MMP2S
+27 ;;30;MCMI2
+28 ;;102;BRS
+29 ;;142;CEMI
+30 ;;143;SNQ
+31 ;;144;CSI
+32 ;;145;FAD
+33 ;;146;IMRA
+34 ;;147;FOCI
+35 ;;148;PCL-5
+36 ;;150;SST-VOI
+37 ;;151;SST-VOF
+38 ;;167;KATZ ADL
+39 ;;192;STOP
+40 ;;193;MDQ
+41 ;;194;CAM
+42 ;;195;PSOCQ
+43 ;;196;PSS
+44 ;;197;DBAS
+45 ;;198;WHOQOL-BREF
+46 ;;199;ISI
+47 ;;201;RLS
+48 ;;203;QOLIE-10
+49 ;;205;SOCRATES 8A
+50 ;;206;SOCRATES 8D
+51 ;;207;ASSIST NIDA
+52 ;;208;BSL-23
+53 ;;209;DERS
+54 ;;210;KTZADL
+55 ;;211;YBOCSII
+56 ;;212;YBOCSII SYMPTOM LIST
+57 ;;213;SIP-2L
+58 ;;214;QOLIE-31
+59 ;;215;CCSA-DSM5
+60 ;;216;SMEQ
+61 ;;217;AAQ-SA
+62 ;;218;CIWA-AR-
+63 ;;;
+64 QUIT
PRETRAN ;Pre-Transportation entry point
+1 ;Copy the MH CHOICETYPE (601.751) entries into the transport global
+2 NEW YSLOOP
+3 SET YSLOOP=0
+4 FOR
SET YSLOOP=$ORDER(^YTT(601.751,YSLOOP))
if 'YSLOOP!(YSLOOP>99999)
QUIT
Begin DoDot:1
+5 SET @XPDGREF@(601.751,YSLOOP)=$GET(^YTT(601.751,YSLOOP,0))
End DoDot:1
+6 QUIT
POST751 ;enter all MH CHOICETYPE (601.751) entries
+1 NEW N,DIK
+2 SET N=0
+3 FOR
SET N=$ORDER(^XTMP("XPDI",XPDA,"TEMP",601.751,N))
if N'>0
QUIT
Begin DoDot:1
+4 SET ^YTT(601.751,N,0)=^XTMP("XPDI",XPDA,"TEMP",601.751,N)
End DoDot:1
+5 SET DIK="^YTT(601.751,"
DO IXALL^DIK
+6 ;Kill existing indexes and re-index
+7 KILL ^YTT(601.76,"B"),^YTT(601.76,"AC"),^YTT(601.76,"AE"),^YTT(601.76,"AD"),^YTT(601.76,"AF")
+8 SET DIK="^YTT(601.76,"
DO IXALL^DIK
+9 KILL ^YTT(601.71,"B")
+10 SET DIK="^YTT(601.71,"
DO IXALL^DIK
+11 KILL ^YTT(601.79,"B"),^YTT(601.79,"AC"),^YTT(601.79,"AD"),^YTT(601.79,"AE"),^YTT(601.79,"AF")
+12 SET DIK="^YTT(601.79,"
DO IXALL^DIK
+13 KILL ^YTT(601.81,"B"),^YTT(601.81,"AC")
+14 SET DIK="^YTT(601.81,"
DO IXALL^DIK
+15 KILL ^YTT(601.83,"B"),^YTT(601.83,"AC"),^YTT(601.83,"C"),^YTT(601.83,"AD")
+16 SET DIK="^YTT(601.83,"
DO IXALL^DIK
+17 KILL ^YTT(601.86,"B"),^YTT(601.86,"AC"),^YTT(601.86,"AD")
+18 SET DIK="^YTT(601.86,"
DO IXALL^DIK
+19 KILL ^YTT(601.93,"B"),^YTT(601.93,"C")
+20 SET DIK="^YTT(601.93,"
DO IXALL^DIK
+21 QUIT
