YS151PST ;SLC/KCM - MH Exchange Sample Code ; 10/11/18 3:01pm
;;5.01;MENTAL HEALTH;**151**;Dec 30, 1994;Build 92
;
EXPDATE ; export date used to update 601.71:18
;;3190815.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 LSTEDT
S LSTEDT=$P($T(EDPDATE+1),";;",2)
;
D CHGNM ;CHANGE INSTRUMENT NAMES
;
D INSTALLQ^YTXCHG("XCHGLST","YS151PST")
D MODDATA ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
;
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","YS151PST")
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
.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)
.K REC
Q
;
INSTDT ;
;;D.BAS^Y^Y^
;;IMRS^Y^Y^
;;ISS-2^Y^Y^
;;I9+C-SSRS^Y^Y^
;;MCMI4^N^N^YSP
;;PROMIS29^Y^Y^
;;Q-LES-Q-SF^Y^Y
;;WHOQOL BREF^Y^Y^
;;zzzzz
;
CHGNM ; Change test name
N REC,IEN,NEW,OLD
F I=1:1 S X=$P($T(NMCHG+I),";;",2,99) Q:X="zzzzz" D
.S OLD=$P(X,"^",1),NEW=$P(X,"^",2)
.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
;
NMCHG ;USED TO CHANGE THE NAME OF AN INSTRUMENT
;;DBAS^D.BAS
;;WHOQOL-BREF^WHOQOL BREF
;;zzzzz
;
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*151^07/24/2019@08:30:57
;;zzzzz
;;YS*5.01*151^07/24/2019@08:30:57
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS151PST 2569 printed Dec 13, 2024@02:12:28 Page 2
YS151PST ;SLC/KCM - MH Exchange Sample Code ; 10/11/18 3:01pm
+1 ;;5.01;MENTAL HEALTH;**151**;Dec 30, 1994;Build 92
+2 ;
EXPDATE ; export date used to update 601.71:18
+1 ;;3190815.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 LSTEDT
+6 SET LSTEDT=$PIECE($TEXT(EDPDATE+1),";;",2)
+7 ;
+8 ;CHANGE INSTRUMENT NAMES
DO CHGNM
+9 ;
+10 DO INSTALLQ^YTXCHG("XCHGLST","YS151PST")
+11 ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
DO MODDATA
+12 ;
+13 QUIT
+14 ;
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","YS151PST")
+6 QUIT
+7 ;
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 FOR I=1:1
SET X=$PIECE($TEXT(INSTDT+I),";;",2)
if X="zzzzz"
QUIT
Begin DoDot:1
+6 SET IEN=$ORDER(^YTT(601.71,"B",$PIECE(X,"^",1),""))
+7 ;LAST EDIT DATE
SET REC(18)=NEWDT
+8 ; WRITE FULL TEXT
IF $PIECE(X,"^",2)'=""
SET REC(26)=$PIECE(X,"^",2)
+9 ;GENERATE PNOTE
IF $PIECE(X,"^",3)'=""
SET REC(28)=$PIECE(X,"^",3)
+10 ;R PRIVILEGE
IF $PIECE(X,"^",4)'=""
SET REC(9)=$PIECE(X,"^",4)
+11 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+12 KILL REC
End DoDot:1
+13 QUIT
+14 ;
INSTDT ;
+1 ;;D.BAS^Y^Y^
+2 ;;IMRS^Y^Y^
+3 ;;ISS-2^Y^Y^
+4 ;;I9+C-SSRS^Y^Y^
+5 ;;MCMI4^N^N^YSP
+6 ;;PROMIS29^Y^Y^
+7 ;;Q-LES-Q-SF^Y^Y
+8 ;;WHOQOL BREF^Y^Y^
+9 ;;zzzzz
+10 ;
CHGNM ; Change test name
+1 NEW REC,IEN,NEW,OLD
+2 FOR I=1:1
SET X=$PIECE($TEXT(NMCHG+I),";;",2,99)
if X="zzzzz"
QUIT
Begin DoDot:1
+3 SET OLD=$PIECE(X,"^",1)
SET NEW=$PIECE(X,"^",2)
+4 SET IEN=$ORDER(^YTT(601.71,"B",OLD,0))
+5 ; already updated
IF 'IEN
QUIT
+6 SET REC(.01)=NEW
+7 SET REC(18)=LSTEDT
+8 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
End DoDot:1
+9 QUIT
+10 ;
NMCHG ;USED TO CHANGE THE NAME OF AN INSTRUMENT
+1 ;;DBAS^D.BAS
+2 ;;WHOQOL-BREF^WHOQOL BREF
+3 ;;zzzzz
+4 ;
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*151^07/24/2019@08:30:57
+2 ;;zzzzz
+3 ;;YS*5.01*151^07/24/2019@08:30:57
