YS139PST ;SLC/BLD - MH Exchange Sample Code ; 10/11/18 3:01pm
;;5.01;MENTAL HEALTH;**139**;Dec 30, 1994;Build 134
;
EXPDATE ; export date used to update 601.71:18
;;3190801.1956
;
PRE ; nothing necessary
Q
POST ; post-init
; UPDSET^YTXCHG("TAG","RTN") will loop through the array returned by TAG^RTN
; and install the specification supplied by that Instrument Exchange entry
; name.
;
N I,YTXLOG,LSTEDT,OLD,NEW,NEWDT,REC,IEN
;
S LSTEDT=$P($T(EXPDATE+1),";;",2)
D CHGNM("DERS","D.ERS")
D DROPTST("RAID")
;
D INSTALLQ^YTXCHG("XCHGLST","YS139PST")
D MODDATA ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
;
Q
;
MODDATA ; Set new dates for tests listed so the GUI will reload the definition
; This is best done in the account where the build is created so that the
; original and destination accounts match.
N I,X,NEWDT,REC
S NEWDT=$P($T(EXPDATE+1),";;",2)
F I=1:1 S X=$P($T(INSTDT+I),";;",2) Q:X="zzzzz" D ; D NEWDATE^YTXCHGU(X,NEWDT)
.K REC
.S IEN=$O(^YTT(601.71,"B",$P(X,"^",1),""))
.S REC(18)=NEWDT ;LAST EDIT DATE
.I $P(X,"^",2)'="" S REC(26)=$P(X,"^",2) ; WRITE FULL TEXT
.I $P(X,"^",3)'="" S REC(28)=$P(X,"^",3) ;GENERATE PNOTE
.I $P(X,"^",4)'="" S REC(9)=$P(X,"^",4) ;R PRIVILEGE
.D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
;
INSTDT ;
;;BBHI-2^N^N^YSP
;;COPD^Y^Y^
;;CSDD-RS^Y^Y^
;;D.ERS^Y^Y^
;;BPRS-A^Y^^
;;HSI^Y^^
;;MHRM^Y^^
;;MPI-PAIN-INTRF^Y^^
;;PCL-5 WEEKLY^Y^^
;;PC-PTSD-5+I9^Y^^
;;PHQ-2+I9^Y^^
;;PSS-3 2ND^Y^^
;;QOLI^N^N^
;;RAID^N^N^
;;zzzzz
;
CHGNM(OLD,NEW) ; Change test name
N REC,IEN
S IEN=$O(^YTT(601.71,"B",OLD,0))
I 'IEN QUIT ; already updated
S REC(.01)=NEW
S REC(18)=LSTEDT
D FMUPD^YTXCHGU(601.71,.REC,IEN)
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(EXPDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
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","YS139PST")
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
ENTRIES ; New MHA instruments ^ Exchange Entry Date
;;YS*5.01*139^08/15/2019@13:36:22
;;zzzzz
;;YS*5.01*139^01/18/2019@13:10:05
;;YS*5.01*139^02/20/2019@10:33:29
;;YS*5.01*139 V31^08/12/2019@12:53:21
;;YS*5.01*139^08/15/2019@13:36:22
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS139PST 2849 printed Sep 23, 2025@19:48:19 Page 2
YS139PST ;SLC/BLD - MH Exchange Sample Code ; 10/11/18 3:01pm
+1 ;;5.01;MENTAL HEALTH;**139**;Dec 30, 1994;Build 134
+2 ;
EXPDATE ; export date used to update 601.71:18
+1 ;;3190801.1956
+2 ;
PRE ; nothing necessary
+1 QUIT
POST ; post-init
+1 ; UPDSET^YTXCHG("TAG","RTN") will loop through the array returned by TAG^RTN
+2 ; and install the specification supplied by that Instrument Exchange entry
+3 ; name.
+4 ;
+5 NEW I,YTXLOG,LSTEDT,OLD,NEW,NEWDT,REC,IEN
+6 ;
+7 SET LSTEDT=$PIECE($TEXT(EXPDATE+1),";;",2)
+8 DO CHGNM("DERS","D.ERS")
+9 DO DROPTST("RAID")
+10 ;
+11 DO INSTALLQ^YTXCHG("XCHGLST","YS139PST")
+12 ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
DO MODDATA
+13 ;
+14 QUIT
+15 ;
MODDATA ; Set new dates for tests listed so the GUI will reload the definition
+1 ; This is best done in the account where the build is created so that the
+2 ; original and destination accounts match.
+3 NEW I,X,NEWDT,REC
+4 SET NEWDT=$PIECE($TEXT(EXPDATE+1),";;",2)
+5 ; D NEWDATE^YTXCHGU(X,NEWDT)
FOR I=1:1
SET X=$PIECE($TEXT(INSTDT+I),";;",2)
if X="zzzzz"
QUIT
Begin DoDot:1
+6 KILL REC
+7 SET IEN=$ORDER(^YTT(601.71,"B",$PIECE(X,"^",1),""))
+8 ;LAST EDIT DATE
SET REC(18)=NEWDT
+9 ; WRITE FULL TEXT
IF $PIECE(X,"^",2)'=""
SET REC(26)=$PIECE(X,"^",2)
+10 ;GENERATE PNOTE
IF $PIECE(X,"^",3)'=""
SET REC(28)=$PIECE(X,"^",3)
+11 ;R PRIVILEGE
IF $PIECE(X,"^",4)'=""
SET REC(9)=$PIECE(X,"^",4)
+12 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
End DoDot:1
+13 QUIT
+14 ;
INSTDT ;
+1 ;;BBHI-2^N^N^YSP
+2 ;;COPD^Y^Y^
+3 ;;CSDD-RS^Y^Y^
+4 ;;D.ERS^Y^Y^
+5 ;;BPRS-A^Y^^
+6 ;;HSI^Y^^
+7 ;;MHRM^Y^^
+8 ;;MPI-PAIN-INTRF^Y^^
+9 ;;PCL-5 WEEKLY^Y^^
+10 ;;PC-PTSD-5+I9^Y^^
+11 ;;PHQ-2+I9^Y^^
+12 ;;PSS-3 2ND^Y^^
+13 ;;QOLI^N^N^
+14 ;;RAID^N^N^
+15 ;;zzzzz
+16 ;
CHGNM(OLD,NEW) ; Change test name
+1 NEW REC,IEN
+2 SET IEN=$ORDER(^YTT(601.71,"B",OLD,0))
+3 ; already updated
IF 'IEN
QUIT
+4 SET REC(.01)=NEW
+5 SET REC(18)=LSTEDT
+6 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+7 QUIT
+8 ;
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(EXPDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
+7 ;
+8 ;
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","YS139PST")
+6 QUIT
+7 ;
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
ENTRIES ; New MHA instruments ^ Exchange Entry Date
+1 ;;YS*5.01*139^08/15/2019@13:36:22
+2 ;;zzzzz
+3 ;;YS*5.01*139^01/18/2019@13:10:05
+4 ;;YS*5.01*139^02/20/2019@10:33:29
+5 ;;YS*5.01*139 V31^08/12/2019@12:53:21
+6 ;;YS*5.01*139^08/15/2019@13:36:22
