YS130PST ;SLC/KCM - Patch 130 Post-Init ; 1/25/2017
;;5.01;MENTAL HEALTH;**130**;Dec 30, 1994;Build 62
;
; External Reference ICR#
; ------------------ -----
; ^VA(200) 10060
; XPDUTL 10141
; XUSAP 4677
;
Q
EDTDATE ; date used to update 601.71:18
;;3190315.1855
Q
POST ; Post-init for YS*5.01*130
D FIXANS("WHODAS2.0-12")
D FIXANS("PSS-3 2ND")
D SAVE96^YTWJSONF ; set up all instruments as JSON files in 601.96
D PROXY ; set up application proxy for patient-entered
D LPSTAFF ; mark instruments that should be staff-entered
D SETCATS^YS130PS0 ; set up instrument categories
Q
PROXY ; Create proxy user
I $$FIND1^DIC(200,"","BQX","YTQR,PATIENTENTRY PROXY")>0 D QUIT
. D MES^XPDUTL("YTQR Proxy Found")
I $$CREATE^XUSAP("YTQR,PATIENTENTRY PROXY","","YTQREST PATIENT ENTRY") D
. D MES^XPDUTL("YTQR Proxy Created")
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,"Y")
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
FIXANS(TESTNM) ; Fix the case of the answer tags for
N SWAP,RPT,TEST,I,X
S SWAP("<*ANSWER_7771*>")="<*Answer_7771*>"
S SWAP("<*ANSWER_7778*>")="<*Answer_7778*>"
N RPT,TEST,I
S TEST=$O(^YTT(601.71,"B",TESTNM,0)) Q:'TEST
S RPT=$O(^YTT(601.93,"C",TEST,0)) Q:'RPT
S I=0 F S I=$O(^YTT(601.93,RPT,1,I)) Q:'I D
. S X=^YTT(601.93,RPT,1,I,0)
. I X["<*ANSWER_" D
. . S X=$$REPLACE^XLFSTR(X,.SWAP)
. . S ^YTT(601.93,RPT,1,I,0)=X
Q
STAFF ; Staff Entry Only Instruments
;;AIMS^
;;BBHI-2^
;;BOMC^
;;BPRS^
;;BPRS-A^
;;BRADEN SCALE^
;;CDR^
;;CIWA-AR-^
;;COPD^
;;COWS^
;;CSDD-RS^
;;CSI^
;;CSI PARTNER VERSION^
;;D.BAS^
;;FAST^
;;GDS DEMENTIA^
;;GPCOG^
;;IADL^
;;ISS-2^
;;I9+C-SSRS^
;;KATZ-ADL-18PT^
;;KATZ-ADL-6PT^
;;MINICOG^
;;MOCA^
;;MOCA ALT 1^
;;MOCA ALT 2^
;;MORSE FALL SCALE^
;;MPI-PAIN-INTRF^
;;PC-PTSD-5+I9^
;;PHQ-2+I9^
;;POQ^
;;PROMIS29^
;;PSS-3^
;;RAID^
;;SBR^
;;SLUMS^
;;SSF^
;;STMS^
;;WHYMPI^
;;zzzzz
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS130PST 2294 printed Dec 13, 2024@02:12:13 Page 2
YS130PST ;SLC/KCM - Patch 130 Post-Init ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130**;Dec 30, 1994;Build 62
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; ^VA(200) 10060
+6 ; XPDUTL 10141
+7 ; XUSAP 4677
+8 ;
+9 QUIT
EDTDATE ; date used to update 601.71:18
+1 ;;3190315.1855
+2 QUIT
POST ; Post-init for YS*5.01*130
+1 DO FIXANS("WHODAS2.0-12")
+2 DO FIXANS("PSS-3 2ND")
+3 ; set up all instruments as JSON files in 601.96
DO SAVE96^YTWJSONF
+4 ; set up application proxy for patient-entered
DO PROXY
+5 ; mark instruments that should be staff-entered
DO LPSTAFF
+6 ; set up instrument categories
DO SETCATS^YS130PS0
+7 QUIT
PROXY ; Create proxy user
+1 IF $$FIND1^DIC(200,"","BQX","YTQR,PATIENTENTRY PROXY")>0
Begin DoDot:1
+2 DO MES^XPDUTL("YTQR Proxy Found")
End DoDot:1
QUIT
+3 IF $$CREATE^XUSAP("YTQR,PATIENTENTRY PROXY","","YTQREST PATIENT ENTRY")
Begin DoDot:1
+4 DO MES^XPDUTL("YTQR Proxy Created")
End DoDot:1
+5 QUIT
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,"Y")
+3 QUIT
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
FIXANS(TESTNM) ; Fix the case of the answer tags for
+1 NEW SWAP,RPT,TEST,I,X
+2 SET SWAP("<*ANSWER_7771*>")="<*Answer_7771*>"
+3 SET SWAP("<*ANSWER_7778*>")="<*Answer_7778*>"
+4 NEW RPT,TEST,I
+5 SET TEST=$ORDER(^YTT(601.71,"B",TESTNM,0))
if 'TEST
QUIT
+6 SET RPT=$ORDER(^YTT(601.93,"C",TEST,0))
if 'RPT
QUIT
+7 SET I=0
FOR
SET I=$ORDER(^YTT(601.93,RPT,1,I))
if 'I
QUIT
Begin DoDot:1
+8 SET X=^YTT(601.93,RPT,1,I,0)
+9 IF X["<*ANSWER_"
Begin DoDot:2
+10 SET X=$$REPLACE^XLFSTR(X,.SWAP)
+11 SET ^YTT(601.93,RPT,1,I,0)=X
End DoDot:2
End DoDot:1
+12 QUIT
STAFF ; Staff Entry Only Instruments
+1 ;;AIMS^
+2 ;;BBHI-2^
+3 ;;BOMC^
+4 ;;BPRS^
+5 ;;BPRS-A^
+6 ;;BRADEN SCALE^
+7 ;;CDR^
+8 ;;CIWA-AR-^
+9 ;;COPD^
+10 ;;COWS^
+11 ;;CSDD-RS^
+12 ;;CSI^
+13 ;;CSI PARTNER VERSION^
+14 ;;D.BAS^
+15 ;;FAST^
+16 ;;GDS DEMENTIA^
+17 ;;GPCOG^
+18 ;;IADL^
+19 ;;ISS-2^
+20 ;;I9+C-SSRS^
+21 ;;KATZ-ADL-18PT^
+22 ;;KATZ-ADL-6PT^
+23 ;;MINICOG^
+24 ;;MOCA^
+25 ;;MOCA ALT 1^
+26 ;;MOCA ALT 2^
+27 ;;MORSE FALL SCALE^
+28 ;;MPI-PAIN-INTRF^
+29 ;;PC-PTSD-5+I9^
+30 ;;PHQ-2+I9^
+31 ;;POQ^
+32 ;;PROMIS29^
+33 ;;PSS-3^
+34 ;;RAID^
+35 ;;SBR^
+36 ;;SLUMS^
+37 ;;SSF^
+38 ;;STMS^
+39 ;;WHYMPI^
+40 ;;zzzzz
+41 ;
