Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YS150PST

YS150PST.m

Go to the documentation of this file. 
  1. YS150PST ;SLC/BLD - MH Exchange Sample Code  ; 10/11/18 3:01pm
  1.  ;;5.01;MENTAL HEALTH;**150**;Dec 30, 1994;Build 210
  1.  ;
  1. EXPDATE ; export date used to update 601.71:18
  1.  ;;3200212.0001
  1. PRE ; nothing necessary
  1.  Q
  1. POST ; post-init
  1.  ; UPDSET^YTXCHG("TAG","RTN") will loop through the array returned by TAG^RTN
  1.  ; and install the specification supplied by that Instrument Exchange entry
  1.  ; name.
  1.  ;
  1.  N I,YTXLOG,LSTEDT,OLD,NEW,NEWDT,REC,IEN
  1.  ;
  1.  S (OLD,NEW)=""
  1.  S LSTEDT=$P($T(EXPDATE+1),";;",2)
  1.  S OLD="NuDESC",NEW="NUDESC" D CHGNM(OLD,NEW) ;Change instrument name only if OLD instrument exists on target system
  1.  S OLD="SIP-AD-Start",NEW="SIP-AD-START" D CHGNM(OLD,NEW)
  1.  ;
  1.  D INSTALLQ^YTXCHG("XCHGLST","YS150PST")
  1.  D LPSTAFF ;Update "Staff Entry Only" field on selected instruments
  1.  D MODDATA   ;CHANGE LAST EDIT DATE, WRITE FULL TEXT, GENERATE PNOTE AND R PRIVILEGE ON INSTRUMENTS IN PATCH
  1.  ;
  1.  Q
  1.  ;
  1. 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
  1.  ; original and destination accounts match.
  1.  N I,X,NEWDT,REC
  1.  S NEWDT=$P($T(EXPDATE+1),";;",2)
  1.  F I=1:1 S X=$P($T(INSTDT+I),";;",2) Q:X="zzzzz"  D
  1.  .S IEN=$O(^YTT(601.71,"B",$P(X,"^",1),""))
  1.  .I IEN D
  1.  ..S REC(18)=NEWDT       ;LAST EDIT DATE
  1.  ..S REC(26)=$P(X,"^",2) ; WRITE FULL TEXT
  1.  ..S REC(28)=$P(X,"^",3) ;GENERATE PNOTE
  1.  ..S REC(9)=$P(X,"^",4)  ;R PRIVILEGE
  1.  ..D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1.  ;
  1. INSTDT ;
  1.  ;;CMQ^Y^Y^
  1.  ;;SIP-AD-30^Y^Y^
  1.  ;;SIP-AD-START^Y^Y
  1.  ;;BSL-23^Y^Y
  1.  ;;NUDESC^Y^Y
  1.  ;;FOCI^Y^Y^
  1.  ;;SWEMWBS^N^N^YSP
  1.  ;;MHRM-10^Y^Y^
  1.  ;;EAT-26^Y^Y^
  1.  ;;ACE^Y^Y^
  1.  ;;AD8^N^N^YSP
  1.  ;;zzzzz
  1.  ;
  1. CHGNM(OLD,NEW) ; Change test name
  1.  ;Q
  1.  N REC,IEN
  1.  S IEN=$O(^YTT(601.71,"B",OLD,0))
  1.  I 'IEN QUIT  ; already updated
  1.  S REC(.01)=NEW
  1.  S REC(18)=LSTEDT
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1.  ;
  1. 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
  1.  ; instrument exchange entries to include in the build.  It sets Y
  1.  ; to true if the entry should be included.
  1.  ; 
  1.  I $$INCLUDE^YTXCHG(Y,"XCHGLST","YS150PST")
  1.  Q
  1.  ;
  1. XCHGLST(ARRAY) ; return array of instrument exchange entries
  1.  ; ARRAY(cnt,1)=instrument exchange entry name
  1.  ; ARRAY(cnt,2)=instrument exchange entry creation date
  1.  ;
  1.  N I,X
  1.  F I=1:1 S X=$P($T(ENTRIES+I),";;",2,99) Q:X="zzzzz"  D
  1.  . S ARRAY(I,1)=$P(X,U)
  1.  . S ARRAY(I,2)=$P(X,U,2)
  1.  Q
  1. ENTRIES ; New MHA instruments ^ Exchange Entry Date
  1.  ;;YS*5.01*150^02/12/2020@08:54:39
  1.  ;;zzzzz
  1.  ;;YS*5.01*150^09/16/2019@12:47:06
  1.  ;;YS*5.01*150^08/29/2019@10:27:56
  1.  ;;YS*5.01*150^09/10/2019@09:27:08
  1.  ;;YS*5.01*150^09/16/2019@12:47:06
  1.  ;
  1. LPSTAFF ; Loop through instruments to set staff entry only
  1.  N I,X,Y
  1.  F I=1:1 D  Q:X="zzzzz"
  1.  . S X=$P($P($T(STAFF+I),";;",2),U) Q:X="zzzzz"
  1.  . S Y=$P($P($T(STAFF+I),";;",2),U,2)
  1.  . D UPDSTAFF(X,Y)
  1.  Q
  1.  ;
  1. UPDSTAFF(NAME,VALUE) ; Update STAFF ENTRY ONLY field
  1.  N IEN,REC
  1.  S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
  1.  S REC(94)=VALUE
  1.  S REC(18)=$P($T(EDTDATE+1),";;",2)
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1.  ;
  1. STAFF ;Staff Entry Only Instruments
  1.  ;;NUDESC^Y
  1.  ;;zzzzz
  1.  ;