YS150PST ;SLC/BLD - MH Exchange Sample Code ; 10/11/18 3:01pm
;;5.01;MENTAL HEALTH;**150**;Dec 30, 1994;Build 210
;
EXPDATE ; export date used to update 601.71:18
;;3200212.0001
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 (OLD,NEW)=""
S LSTEDT=$P($T(EXPDATE+1),";;",2)
S OLD="NuDESC",NEW="NUDESC" D CHGNM(OLD,NEW) ;Change instrument name only if OLD instrument exists on target system
S OLD="SIP-AD-Start",NEW="SIP-AD-START" D CHGNM(OLD,NEW)
;
D INSTALLQ^YTXCHG("XCHGLST","YS150PST")
D LPSTAFF ;Update "Staff Entry Only" field on selected instruments
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
.S IEN=$O(^YTT(601.71,"B",$P(X,"^",1),""))
.I IEN D
..S REC(18)=NEWDT ;LAST EDIT DATE
..S REC(26)=$P(X,"^",2) ; WRITE FULL TEXT
..S REC(28)=$P(X,"^",3) ;GENERATE PNOTE
..S REC(9)=$P(X,"^",4) ;R PRIVILEGE
..D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
;
INSTDT ;
;;CMQ^Y^Y^
;;SIP-AD-30^Y^Y^
;;SIP-AD-START^Y^Y
;;BSL-23^Y^Y
;;NUDESC^Y^Y
;;FOCI^Y^Y^
;;SWEMWBS^N^N^YSP
;;MHRM-10^Y^Y^
;;EAT-26^Y^Y^
;;ACE^Y^Y^
;;AD8^N^N^YSP
;;zzzzz
;
CHGNM(OLD,NEW) ; Change test name
;Q
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
;
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","YS150PST")
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*150^02/12/2020@08:54:39
;;zzzzz
;;YS*5.01*150^09/16/2019@12:47:06
;;YS*5.01*150^08/29/2019@10:27:56
;;YS*5.01*150^09/10/2019@09:27:08
;;YS*5.01*150^09/16/2019@12:47:06
;
LPSTAFF ; Loop through instruments to set staff entry only
N I,X,Y
F I=1:1 D Q:X="zzzzz"
. S X=$P($P($T(STAFF+I),";;",2),U) Q:X="zzzzz"
. S Y=$P($P($T(STAFF+I),";;",2),U,2)
. 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
;
STAFF ;Staff Entry Only Instruments
;;NUDESC^Y
;;zzzzz
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS150PST 3213 printed Dec 13, 2024@02:12:27 Page 2
YS150PST ;SLC/BLD - MH Exchange Sample Code ; 10/11/18 3:01pm
+1 ;;5.01;MENTAL HEALTH;**150**;Dec 30, 1994;Build 210
+2 ;
EXPDATE ; export date used to update 601.71:18
+1 ;;3200212.0001
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 (OLD,NEW)=""
+8 SET LSTEDT=$PIECE($TEXT(EXPDATE+1),";;",2)
+9 ;Change instrument name only if OLD instrument exists on target system
SET OLD="NuDESC"
SET NEW="NUDESC"
DO CHGNM(OLD,NEW)
+10 SET OLD="SIP-AD-Start"
SET NEW="SIP-AD-START"
DO CHGNM(OLD,NEW)
+11 ;
+12 DO INSTALLQ^YTXCHG("XCHGLST","YS150PST")
+13 ;Update "Staff Entry Only" field on selected instruments
DO LPSTAFF
+14 ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
DO MODDATA
+15 ;
+16 QUIT
+17 ;
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 IF IEN
Begin DoDot:2
+8 ;LAST EDIT DATE
SET REC(18)=NEWDT
+9 ; WRITE FULL TEXT
SET REC(26)=$PIECE(X,"^",2)
+10 ;GENERATE PNOTE
SET REC(28)=$PIECE(X,"^",3)
+11 ;R PRIVILEGE
SET REC(9)=$PIECE(X,"^",4)
+12 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
INSTDT ;
+1 ;;CMQ^Y^Y^
+2 ;;SIP-AD-30^Y^Y^
+3 ;;SIP-AD-START^Y^Y
+4 ;;BSL-23^Y^Y
+5 ;;NUDESC^Y^Y
+6 ;;FOCI^Y^Y^
+7 ;;SWEMWBS^N^N^YSP
+8 ;;MHRM-10^Y^Y^
+9 ;;EAT-26^Y^Y^
+10 ;;ACE^Y^Y^
+11 ;;AD8^N^N^YSP
+12 ;;zzzzz
+13 ;
CHGNM(OLD,NEW) ; Change test name
+1 ;Q
+2 NEW REC,IEN
+3 SET IEN=$ORDER(^YTT(601.71,"B",OLD,0))
+4 ; already updated
IF 'IEN
QUIT
+5 SET REC(.01)=NEW
+6 SET REC(18)=LSTEDT
+7 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+8 QUIT
+9 ;
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","YS150PST")
+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*150^02/12/2020@08:54:39
+2 ;;zzzzz
+3 ;;YS*5.01*150^09/16/2019@12:47:06
+4 ;;YS*5.01*150^08/29/2019@10:27:56
+5 ;;YS*5.01*150^09/10/2019@09:27:08
+6 ;;YS*5.01*150^09/16/2019@12:47:06
+7 ;
LPSTAFF ; Loop through instruments to set staff entry only
+1 NEW I,X,Y
+2 FOR I=1:1
Begin DoDot:1
+3 SET X=$PIECE($PIECE($TEXT(STAFF+I),";;",2),U)
if X="zzzzz"
QUIT
+4 SET Y=$PIECE($PIECE($TEXT(STAFF+I),";;",2),U,2)
+5 DO UPDSTAFF(X,Y)
End DoDot:1
if X="zzzzz"
QUIT
+6 QUIT
+7 ;
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 ;;NUDESC^Y
+2 ;;zzzzz
+3 ;
