YS141PST ;BAH/QSB - Patch 141 Post-Init ; 1/27/2020
;;5.01;MENTAL HEALTH;**141**;Dec 30, 1994;Build 85
;
; External Reference ICR#
; ------------------ -----
; XPDUTL 10141
;
Q
EDTDATE ; date used to update 601.71:18
;;3200227.0006
Q
POST ; Post-init for YS*5.01*141
D INSTALLQ^YTXCHG("XCHGLST","YS141PST")
D LPSTAFF ; mark instruments that should be staff-entered
D DROPTST("SBR")
D SETAUDC
D SETSWEM
D SETQOLI
D FIXNEO3
D SETMOCA^YS141MCA
I '$$GET^XPAR("ALL","YSMOCA ATTESTATION ENABLED") D QMOCA^YS141MCA
D SETCATS^YS141PS0
Q
;
SCREEN ; sample line to put in DATA SCREEN of KIDS build
; $$INCLUDE^YTXCHG(Y,"TAG","RTN") calls TAG^RTN to get an array of
; instrument exchange entries to include in the build. It sets Y
; to true if the entry should be included.
;
I $$INCLUDE^YTXCHG(Y,"XCHGLST","YTXCHGS")
Q
;
DROPTST(NAME) ; Change OPERATIONAL to dropped
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(10)="D"
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
;
SETAUDC ; Set date AUDC scoring changed
I $$GET^XPAR("SYS","YSAUDC CHANGE DATE",1,"I") QUIT
D EN^XPAR("SYS","YSAUDC CHANGE DATE",1,$$NOW^XLFDT)
Q
SETSWEM ; Update key fields in SWEMWBS
N IEN,REC
S IEN=$O(^YTT(601.71,"B","SWEMWBS",0)) Q:'IEN
S REC(9)="" ; read result privilege
S REC(26)="Y" ; write full text
S REC(28)="Y" ; generate progress note
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
SETQOLI ; Update scoring revision in QOLI
N IEN,REC
S IEN=$O(^YTT(601.71,"B","QOLI",0)) Q:'IEN
S REC(93)=3
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
FIXNEO3 ; Remove the stub rule for NEO-PI-3
N TEST,REC
S TEST=$O(^YTT(601.71,"B","NEO-PI-3",0)) Q:'TEST
; remove the erroneous association (question 5723 and rule 93)
I $P($G(^YTT(601.83,93,0)),U,2)=TEST D FMDEL^YTXCHGU(601.83,93)
; remove the erroneous rule 93 (which has no skipped questions)
I $P($G(^YTT(601.82,149,0)),U,2)=5723 D FMDEL^YTXCHGU(601.82,149)
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,TEST)
Q
XCHGLST(ARRAY) ; return array of instrument exchange entries
; ARRAY(cnt,1)=instrument exchange entry name
; ARRAY(cnt,2)=instrument exchange entry creation date
;
N I,X
F I=1:1 S X=$P($T(ENTRIES+I),";;",2,99) Q:X="zzzzz" D
. S ARRAY(I,1)=$P(X,U)
. S ARRAY(I,2)=$P(X,U,2)
Q
;
LPSTAFF ; Loop through instruments to set staff entry only
N I,X
F I=1:1 S X=$P($P($T(STAFF+I),";;",2),U) Q:X="zzzzz" D UPDSTAFF(X,"N")
Q
;
UPDSTAFF(NAME,VALUE) ; Update STAFF ENTRY ONLY field
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(94)=VALUE
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
;
STAFF ;Staff Entry Only Instruments
;;BBHI-2^
;;CSI^
;;CSI PARTNER VERSION^
;;D.BAS^
;;ISS-2^
;;I9+C-SSRS^
;;MPI-PAIN-INTRF^
;;PC-PTSD-5+I9^
;;PHQ-2+I9^
;;POQ^
;;PROMIS29^
;;PSS-3^
;;SSF^
;;WHYMPI^
;;zzzzz
;
ENTRIES ; New MHA instruments ^ Exchange Entry Date
;;YS*5.01*141 PSS-3^01/30/2020@13:30:42
;;YS*5.01*141 CIWA-AR REPORT^03/12/2020@18:14:40
;;YS*5.01*141 PHQ9 SCORING^05/14/2020@23:38:19
;;YS*5.01*141 SWEMWBS REPORT^06/09/2020@11:25:32
;;YS*5.01*141 AUDC UPDATE^06/23/2020@19:50:32
;;YS*5.01*141 D.BAS TYPO^08/12/2020@17:23:14
;;zzzzz
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS141PST 3433 printed Dec 13, 2024@02:12:21 Page 2
YS141PST ;BAH/QSB - Patch 141 Post-Init ; 1/27/2020
+1 ;;5.01;MENTAL HEALTH;**141**;Dec 30, 1994;Build 85
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; XPDUTL 10141
+6 ;
+7 QUIT
EDTDATE ; date used to update 601.71:18
+1 ;;3200227.0006
+2 QUIT
POST ; Post-init for YS*5.01*141
+1 DO INSTALLQ^YTXCHG("XCHGLST","YS141PST")
+2 ; mark instruments that should be staff-entered
DO LPSTAFF
+3 DO DROPTST("SBR")
+4 DO SETAUDC
+5 DO SETSWEM
+6 DO SETQOLI
+7 DO FIXNEO3
+8 DO SETMOCA^YS141MCA
+9 IF '$$GET^XPAR("ALL","YSMOCA ATTESTATION ENABLED")
DO QMOCA^YS141MCA
+10 DO SETCATS^YS141PS0
+11 QUIT
+12 ;
SCREEN ; sample line to put in DATA SCREEN of KIDS build
+1 ; $$INCLUDE^YTXCHG(Y,"TAG","RTN") calls TAG^RTN to get an array of
+2 ; instrument exchange entries to include in the build. It sets Y
+3 ; to true if the entry should be included.
+4 ;
+5 IF $$INCLUDE^YTXCHG(Y,"XCHGLST","YTXCHGS")
+6 QUIT
+7 ;
DROPTST(NAME) ; Change OPERATIONAL to dropped
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(10)="D"
+4 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
+7 ;
SETAUDC ; Set date AUDC scoring changed
+1 IF $$GET^XPAR("SYS","YSAUDC CHANGE DATE",1,"I")
QUIT
+2 DO EN^XPAR("SYS","YSAUDC CHANGE DATE",1,$$NOW^XLFDT)
+3 QUIT
SETSWEM ; Update key fields in SWEMWBS
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B","SWEMWBS",0))
if 'IEN
QUIT
+3 ; read result privilege
SET REC(9)=""
+4 ; write full text
SET REC(26)="Y"
+5 ; generate progress note
SET REC(28)="Y"
+6 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+7 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+8 QUIT
SETQOLI ; Update scoring revision in QOLI
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B","QOLI",0))
if 'IEN
QUIT
+3 SET REC(93)=3
+4 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
FIXNEO3 ; Remove the stub rule for NEO-PI-3
+1 NEW TEST,REC
+2 SET TEST=$ORDER(^YTT(601.71,"B","NEO-PI-3",0))
if 'TEST
QUIT
+3 ; remove the erroneous association (question 5723 and rule 93)
+4 IF $PIECE($GET(^YTT(601.83,93,0)),U,2)=TEST
DO FMDEL^YTXCHGU(601.83,93)
+5 ; remove the erroneous rule 93 (which has no skipped questions)
+6 IF $PIECE($GET(^YTT(601.82,149,0)),U,2)=5723
DO FMDEL^YTXCHGU(601.82,149)
+7 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+8 DO FMUPD^YTXCHGU(601.71,.REC,TEST)
+9 QUIT
XCHGLST(ARRAY) ; return array of instrument exchange entries
+1 ; ARRAY(cnt,1)=instrument exchange entry name
+2 ; ARRAY(cnt,2)=instrument exchange entry creation date
+3 ;
+4 NEW I,X
+5 FOR I=1:1
SET X=$PIECE($TEXT(ENTRIES+I),";;",2,99)
if X="zzzzz"
QUIT
Begin DoDot:1
+6 SET ARRAY(I,1)=$PIECE(X,U)
+7 SET ARRAY(I,2)=$PIECE(X,U,2)
End DoDot:1
+8 QUIT
+9 ;
LPSTAFF ; Loop through instruments to set staff entry only
+1 NEW I,X
+2 FOR I=1:1
SET X=$PIECE($PIECE($TEXT(STAFF+I),";;",2),U)
if X="zzzzz"
QUIT
DO UPDSTAFF(X,"N")
+3 QUIT
+4 ;
UPDSTAFF(NAME,VALUE) ; Update STAFF ENTRY ONLY field
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(94)=VALUE
+4 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
+7 ;
STAFF ;Staff Entry Only Instruments
+1 ;;BBHI-2^
+2 ;;CSI^
+3 ;;CSI PARTNER VERSION^
+4 ;;D.BAS^
+5 ;;ISS-2^
+6 ;;I9+C-SSRS^
+7 ;;MPI-PAIN-INTRF^
+8 ;;PC-PTSD-5+I9^
+9 ;;PHQ-2+I9^
+10 ;;POQ^
+11 ;;PROMIS29^
+12 ;;PSS-3^
+13 ;;SSF^
+14 ;;WHYMPI^
+15 ;;zzzzz
+16 ;
ENTRIES ; New MHA instruments ^ Exchange Entry Date
+1 ;;YS*5.01*141 PSS-3^01/30/2020@13:30:42
+2 ;;YS*5.01*141 CIWA-AR REPORT^03/12/2020@18:14:40
+3 ;;YS*5.01*141 PHQ9 SCORING^05/14/2020@23:38:19
+4 ;;YS*5.01*141 SWEMWBS REPORT^06/09/2020@11:25:32
+5 ;;YS*5.01*141 AUDC UPDATE^06/23/2020@19:50:32
+6 ;;YS*5.01*141 D.BAS TYPO^08/12/2020@17:23:14
+7 ;;zzzzz
