YS129PST ;SLC/LLH - Patch 129 post-init ; 03/20/2017
;;5.01;MENTAL HEALTH;**129**;Dec 30, 1994;Build 12
;
; This patch moves 13 instruments to "dropped" and updates the Scale Group name for 2 instruments
; so charting works better (there were additional Scale Group updates but those instruments are in patch 121)
Q
;
;
EDTDATE ; date used to update 601.71:18
;;3170322.1321
Q
;
POST ; Post-init calls for patch 129
N NM
D GETSG
D ADDIDX ; add indices for CESD -- Center for Epidemiologic Studies Depression Scale
D PHQ9CT ; switch choices in PHQ9 to be 0-3 instead of 1-4
; drop tests: note CIWA-AR was in this list, can't do as CIWA-AR- not released
F NM="AUIR","CESD5","DOM80","DOMG","ERS","HLOC" D DROPTST(NM)
F NM="IEQ","RLOC","SAI","SDES","SMAST","VALD","WAS" D DROPTST(NM)
D UPDVER^YTQAPI7(3,"1.0.3.72") ; set MHA client version
Q
;
GETSG ; Update Scale Group name
N IDX,SGIEN,SGNM,TSTIEN,TSTNM
S IDX=0 F S IDX=IDX+1,TSTNM=$P($T(TESTS+IDX),";;",2) Q:TSTNM="zzzzz" D
.S TSTIEN=$O(^YTT(601.71,"B",TSTNM,0)) Q:'TSTIEN
.S SGIEN=$O(^YTT(601.86,"AD",TSTIEN,0)) Q:'SGIEN
.S SGNM=$P($T(TESTS+IDX),";;",3)
.D UPDSG(SGIEN,SGNM) ; update Scale Group Name
Q
;
UPDSG(SGIEN,SGNM) ; update Scale Group Name
N FDA,DIERR
S FDA(601.86,SGIEN_",",2)=SGNM
D FILE^DIE("","FDA")
I $D(DIERR) D BMES^XPDUTL("ERROR: "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
;
ADDIDX ; add indices for CESD
N TSTIEN,SGIEN
S TSTIEN=$O(^YTT(601.71,"B","CESD",0))
I 'TSTIEN D BMES^XPDUTL("ERROR: "_$G(^TMP("DIERR",$J,1,"TEXT",1))),CLEAN^DILF
S SGIEN=$O(^YTT(601.86,"AD",TSTIEN,0))
I 'SGIEN D BMES^XPDUTL("ERROR: "_$G(^TMP("DIERR",$J,1,"TEXT",1))),CLEAN^DILF
S ^YTT(601.86,"B",SGIEN,SGIEN)=""
S ^YTT(601.86,"AD",TSTIEN,SGIEN)=""
S ^YTT(601.86,"AC",TSTIEN,1,SGIEN)=""
Q
;
DROPTST(NAME) ; Change OPERATIONAL to dropped, update LAST EDIT DATE
N IEN
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
D FLD2DROP(IEN)
Q
;
FLD2DROP(IEN) ; update OPERATIONAL field to be "Dropped", LAST EDIT DATE
N FDA,DIERR
S FDA(601.71,IEN_",",10)="D"
S FDA(601.71,IEN_",",18)=$P($T(EDTDATE+1),";;",2)
D FILE^DIE("","FDA")
I $D(DIERR) D MES^XPDUTL("ERROR: "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
;
PHQ9CT ; update PHQ9 choice type
N TEST,SEQ,CTNT,X0,X2,QSTN,CTYP,CID
S TEST=$O(^YTT(601.71,"B","PHQ9",0))
S SEQ=0 F S SEQ=$O(^YTT(601.76,"AD",TEST,SEQ)) Q:'SEQ D
. S CTNT=0 F S CTNT=$O(^YTT(601.76,"AD",TEST,SEQ,CTNT)) Q:'CTNT D
. . S X0=^YTT(601.76,CTNT,0),QSTN=$P(X0,U,4)
. . S X2=^YTT(601.72,QSTN,2),CTYP=$P(X2,U,3)
. . S CID=$O(^YTT(601.89,"B",CTYP,0)) Q:'CID
. . N CHG S CHG(1)=0
. . D UPDANY(601.89,CID,.CHG)
. . K CHG S CHG(18)=$P($T(EDTDATE+1),";;",2)
. . D UPDANY(601.71,TEST,.CHG)
Q
UPDANY(FILEN,IEN,CHGS) ; update any MH record
Q:FILEN<601 Q:FILEN>604 ; limit to MH files
N FDA,DIERR
M FDA(FILEN,IEN_",")=CHGS
D FILE^DIE("","FDA")
I $D(DIERR) D BMES^XPDUTL("ERROR: "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
K CHGS ; clean up for next call
Q
;
TESTS ; Scale Group Names updated
;;AUDIT;;AUDIT Scale
;;PCL-5;;PCL-5 Scale
;;zzzzz
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS129PST 3180 printed Dec 13, 2024@02:12:11 Page 2
YS129PST ;SLC/LLH - Patch 129 post-init ; 03/20/2017
+1 ;;5.01;MENTAL HEALTH;**129**;Dec 30, 1994;Build 12
+2 ;
+3 ; This patch moves 13 instruments to "dropped" and updates the Scale Group name for 2 instruments
+4 ; so charting works better (there were additional Scale Group updates but those instruments are in patch 121)
+5 QUIT
+6 ;
+7 ;
EDTDATE ; date used to update 601.71:18
+1 ;;3170322.1321
+2 QUIT
+3 ;
POST ; Post-init calls for patch 129
+1 NEW NM
+2 DO GETSG
+3 ; add indices for CESD -- Center for Epidemiologic Studies Depression Scale
DO ADDIDX
+4 ; switch choices in PHQ9 to be 0-3 instead of 1-4
DO PHQ9CT
+5 ; drop tests: note CIWA-AR was in this list, can't do as CIWA-AR- not released
+6 FOR NM="AUIR","CESD5","DOM80","DOMG","ERS","HLOC"
DO DROPTST(NM)
+7 FOR NM="IEQ","RLOC","SAI","SDES","SMAST","VALD","WAS"
DO DROPTST(NM)
+8 ; set MHA client version
DO UPDVER^YTQAPI7(3,"1.0.3.72")
+9 QUIT
+10 ;
GETSG ; Update Scale Group name
+1 NEW IDX,SGIEN,SGNM,TSTIEN,TSTNM
+2 SET IDX=0
FOR
SET IDX=IDX+1
SET TSTNM=$PIECE($TEXT(TESTS+IDX),";;",2)
if TSTNM="zzzzz"
QUIT
Begin DoDot:1
+3 SET TSTIEN=$ORDER(^YTT(601.71,"B",TSTNM,0))
if 'TSTIEN
QUIT
+4 SET SGIEN=$ORDER(^YTT(601.86,"AD",TSTIEN,0))
if 'SGIEN
QUIT
+5 SET SGNM=$PIECE($TEXT(TESTS+IDX),";;",3)
+6 ; update Scale Group Name
DO UPDSG(SGIEN,SGNM)
End DoDot:1
+7 QUIT
+8 ;
UPDSG(SGIEN,SGNM) ; update Scale Group Name
+1 NEW FDA,DIERR
+2 SET FDA(601.86,SGIEN_",",2)=SGNM
+3 DO FILE^DIE("","FDA")
+4 IF $DATA(DIERR)
DO BMES^XPDUTL("ERROR: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+5 DO CLEAN^DILF
+6 QUIT
+7 ;
ADDIDX ; add indices for CESD
+1 NEW TSTIEN,SGIEN
+2 SET TSTIEN=$ORDER(^YTT(601.71,"B","CESD",0))
+3 IF 'TSTIEN
DO BMES^XPDUTL("ERROR: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
DO CLEAN^DILF
+4 SET SGIEN=$ORDER(^YTT(601.86,"AD",TSTIEN,0))
+5 IF 'SGIEN
DO BMES^XPDUTL("ERROR: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
DO CLEAN^DILF
+6 SET ^YTT(601.86,"B",SGIEN,SGIEN)=""
+7 SET ^YTT(601.86,"AD",TSTIEN,SGIEN)=""
+8 SET ^YTT(601.86,"AC",TSTIEN,1,SGIEN)=""
+9 QUIT
+10 ;
DROPTST(NAME) ; Change OPERATIONAL to dropped, update LAST EDIT DATE
+1 NEW IEN
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 DO FLD2DROP(IEN)
+4 QUIT
+5 ;
FLD2DROP(IEN) ; update OPERATIONAL field to be "Dropped", LAST EDIT DATE
+1 NEW FDA,DIERR
+2 SET FDA(601.71,IEN_",",10)="D"
+3 SET FDA(601.71,IEN_",",18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+4 DO FILE^DIE("","FDA")
+5 IF $DATA(DIERR)
DO MES^XPDUTL("ERROR: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+6 DO CLEAN^DILF
+7 QUIT
+8 ;
PHQ9CT ; update PHQ9 choice type
+1 NEW TEST,SEQ,CTNT,X0,X2,QSTN,CTYP,CID
+2 SET TEST=$ORDER(^YTT(601.71,"B","PHQ9",0))
+3 SET SEQ=0
FOR
SET SEQ=$ORDER(^YTT(601.76,"AD",TEST,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+4 SET CTNT=0
FOR
SET CTNT=$ORDER(^YTT(601.76,"AD",TEST,SEQ,CTNT))
if 'CTNT
QUIT
Begin DoDot:2
+5 SET X0=^YTT(601.76,CTNT,0)
SET QSTN=$PIECE(X0,U,4)
+6 SET X2=^YTT(601.72,QSTN,2)
SET CTYP=$PIECE(X2,U,3)
+7 SET CID=$ORDER(^YTT(601.89,"B",CTYP,0))
if 'CID
QUIT
+8 NEW CHG
SET CHG(1)=0
+9 DO UPDANY(601.89,CID,.CHG)
+10 KILL CHG
SET CHG(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+11 DO UPDANY(601.71,TEST,.CHG)
End DoDot:2
End DoDot:1
+12 QUIT
UPDANY(FILEN,IEN,CHGS) ; update any MH record
+1 ; limit to MH files
if FILEN<601
QUIT
if FILEN>604
QUIT
+2 NEW FDA,DIERR
+3 MERGE FDA(FILEN,IEN_",")=CHGS
+4 DO FILE^DIE("","FDA")
+5 IF $DATA(DIERR)
DO BMES^XPDUTL("ERROR: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+6 DO CLEAN^DILF
+7 ; clean up for next call
KILL CHGS
+8 QUIT
+9 ;
TESTS ; Scale Group Names updated
+1 ;;AUDIT;;AUDIT Scale
+2 ;;PCL-5;;PCL-5 Scale
+3 ;;zzzzz
+4 ;
