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

LR343.m

Go to the documentation of this file. 
  1. LR343 ;VA/DALOI/JDB - LR*5.2*343 KIDS ROUTINE
  1.  ;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 343
  1.  ;
  1.  ;
  1.  ; Send email if #69.9 fields set to Yes
  1.  ; Set LR7O MOVEMENT EVENT protocols DISABLE and ACTION fields
  1.  ; Pause X minutes so any running protocols can clear
  1.  ; KIDS deletes LR7OEVNT routine
  1.  ; KIDS deletes LR7O MOVEMENT EVENT protocols
  1.  ; Delete data from #69.9 fields
  1.  ; Delete #69.9 fields DD
  1.  ; 
  1.  ; 
  1. EN ;
  1.  ; Environment Check
  1.  ; Does not prevent loading of the transport global.
  1.  ;
  1.  D BMES^XPDUTL($$CJ^XLFSTR("--- Environment check of patch "_$G(XPDNM,"Unknown patch")_" started on "_$$HTE^XLFDT($H)_" ---",IOM))    ; IHS/MSC/MKK
  1.  ;
  1.  D CLEAN
  1.  D CHECK
  1.  I $G(XPDQUIT) D  Q  ;
  1.  . ; W !,$$CJ^XLFSTR("Environment check failed",$G(IOM,80))
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check for "_$G(XPDNM,"Unknown patch")_" FAILED ---",80))  ; IHS/MSC/MKK
  1.  ;
  1.  ; W !,$$CJ^XLFSTR("Environment is okay",$G(IOM,80))
  1.  D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check for "_$G(XPDNM,"Unknown patch")_" is okay ---",80))  ; IHS/MSC/MKK
  1.  ;
  1.  D ALERT("Installation of patch "_$G(XPDNM,"Unknown patch")_" started on "_$$HTE^XLFDT($H))
  1.  I '$G(XPDENV) D  Q
  1.  . D ALERT("Transport global for patch "_$G(XPDNM,"Unknown patch")_" loaded on "_$$HTE^XLFDT($H))
  1.  . ; D MSGADD("Sending transport global loaded alert to mail group G.LMI")
  1.  Q
  1.  ;
  1. CHECK ;
  1.  ; Perform environment check
  1.  N POP
  1.  ; Is Home device defined
  1.  ; Need Home device so "task install" option is displayed
  1.  S POP=0 S IOP="",%ZIS=0 D ^%ZIS
  1.  I POP D  Q
  1.  . S XPDQUIT=2
  1.  . W !,$$CJ^XLFSTR("*** Home device is not defined ***",$G(IOM,80))
  1.  ;
  1.  ; Device Defined
  1.  I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D  Q
  1.  . W !,$$CJ^XLFSTR("*** Terminal Device is not defined ***",$G(IOM,80))
  1.  . S XPDQUIT=2
  1.  ;
  1.  ; DUZ setup
  1.  I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D  Q
  1.  . W !,$$CJ^XLFSTR("*** Please log in to set variables ***",$G(IOM,80))
  1.  . S XPDQUIT=2
  1.  ;
  1.  ; Active User
  1.  I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D  Q
  1.  . W !,$$CJ^XLFSTR("*** You are not a valid user on this system ***",$G(IOM,80))
  1.  . S XPDQUIT=2
  1.  ;
  1.  ; KIDS default answer to "Disable Protocols...."
  1.  S XPDDIQ("XPZ1")=0  ;;Dont allow disabling options
  1.  S XPDDIQ("XPZ1","B")="NO"
  1.  Q
  1.  ;
  1. PRE ;
  1.  ; KIDS Pre Install
  1.  ; Check that install was tasked
  1.  ; Check if any File #69.9 fields are set to "YES" If so send
  1.  ; notification email.
  1.  ; Disable Lab Protocols (set DISABLED field and set ACTION to Q)
  1.  ; Hang so current processes started by protocols can end
  1.  N IEN,ERR,PREERR,RECIPS,BODY,VALS,STR
  1.  S PREERR=0
  1.  D MSGADD("Pre install started at "_$$HTE^XLFDT($H))
  1.  ;
  1.  ; Was install tasked? Quit if not
  1.  ; ----- BEGIN IHS/MSC/MKK
  1.  ;      Cannot be tasked -- part of an IHS Lab Patch multi-Build.
  1.  ;      Check for Queued status will be skipped.
  1.  ; ----- END IHS/MSC/MKK
  1.  ; I '$D(ZTQUEUED) I $G(IO("Q"))="" D  Q
  1.  ; . S XPDQUIT=2
  1.  ; . S XPDABORT=2
  1.  ; . D MSGADD("***  THIS INSTALLATION MUST BE TASKED  ***")
  1.  ; . D MSGADD("",0)
  1.  ; . D MSGADD("Refer to the Patch Installation instructions",0)
  1.  ; . D MSGADD("for details concerning re-running the install.",0)
  1.  ; . D CLEAN
  1.  ;
  1.  ; check DD field values and send email if any are YES
  1.  S VALS=$$GETVALS()
  1.  I VALS>0 D  ;
  1.  . S STR="File #69.9 LABORATORY SITE has one or more fields that were set to YES."
  1.  . D BLDBODY(STR,.BODY)
  1.  . S STR="    #150.3  CANCEL ON ADMIT set to "_$S($E(VALS,1,1):"YES",1:"NO")
  1.  . D BLDBODY(STR,.BODY)
  1.  . S STR="    #150.4  CANCEL ON DISCHARGE set to "_$S($E(VALS,2,2):"YES",1:"NO")
  1.  . D BLDBODY(STR,.BODY)
  1.  . S STR="    #150.5  CANCEL ON SPECIALTY set to "_$S($E(VALS,3,3):"YES",1:"NO")
  1.  . D BLDBODY(STR,.BODY)
  1.  . D BLDBODY(" ",.BODY)
  1.  . S STR="One or more DC fields of File #69.9 are set to Yes. These fields should have been set to No according to guidelines issued with the release of OR*3*142 and OR*3*141."
  1.  . S STR=STR_"  Facilities would be advised to use the functionality provided in file #100.6 (released with OR*3*142) to maintain the ability to auto discontinue laboratory orders upon a patient movement."
  1.  . S STR=STR_"  Please check your configurations to ensure that this migration has occurred."
  1.  . D BLDBODY(STR,.BODY)
  1.  . S RECIPS(DUZ)=""
  1.  . S RECIPS("G.LMI")=""
  1.  . D EMAIL("LR*5.2*343 -- 69.9 DC Fields","BODY",.RECIPS)
  1.  . K BODY
  1.  . D MSGADD("***  File #69.9 field(s) set to YES  ***")
  1.  ;
  1.  D ALERT("LR*5.2*343 Installation has started")
  1.  ; D MSGADD("Sent install started alert to mail group G.LMI")
  1.  ;
  1.  ; Disable Protocols and set action event to quit
  1.  D MSGADD("Setting DISABLE and ACTION fields for Protocols")
  1.  S IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT","B",,"ERR")
  1.  I IEN D UPDTPROT(IEN)
  1.  I 'IEN D MSGADD("***  Did not find LR7O MOVEMENT EVENT PROTOCOL  ***")
  1.  S IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT TASK","B",,"ERR")
  1.  I IEN D UPDTPROT(IEN)
  1.  I 'IEN D MSGADD("***  Did not find LR7O MOVEMENT EVENT TASK PROTOCOL  ***")
  1.  ;
  1.  ; Now hang for X minutes to let all existing triggered
  1.  ; events to clear so we don't cause any "cant return to source"
  1.  ; errors when we overwrite the protocl's routine which would
  1.  ; cause the other chained events not to be processed (the hang is
  1.  ; why the install is tasked and not run in direct mode)
  1.  ; 
  1.  ; ----- BEGIN IHS/MSC/MKK
  1.  ;       Notes above about Tasked install are VA notes.
  1.  ;       This install is not tasked becuase it's part of a mega-build.
  1.  ;       Just pause 5 minutes after giving Installer message.
  1.  D BIGHONK
  1.  ; ----- END IHS/MSC/MKK
  1.  ;
  1.  H 300        ; Pause 5 Minutes
  1.  ;
  1.  I 'PREERR D MSGADD("No actions required for pre install")
  1.  D MSGADD("Pre install completed at "_$$HTE^XLFDT($H))
  1.  Q
  1.  ;
  1. POST ;
  1.  ; KIDS Post Install
  1.  ; Delete data in File #69.9 fields
  1.  ; Remove #69.9 fields from Data Dictionary
  1.  ; Email installation progress message
  1.  N DA,DIK,LRFDA,LRMSG,LRMSG2,POSTERR,RECIPS
  1.  S POSTERR=0
  1.  D MSGADD("Post install started at "_$$HTE^XLFDT($H))
  1.  D MSGADD("File #69.9 field data update started")
  1.  ; delete #69.9 field data
  1.  S LRFDA(1,69.9,"1,",150.3)="@"
  1.  S LRFDA(1,69.9,"1,",150.4)="@"
  1.  S LRFDA(1,69.9,"1,",150.5)="@"
  1.  K MSG
  1.  D FILE^DIE("","LRFDA(1)","LRMSG")
  1.  I $D(LRMSG) D  ;
  1.  . K LRMSG2
  1.  . D MSG^DIALOG("ASEM",.LRMSG2,$G(IOM,80),,"LRMSG")
  1.  . ; S POSTERR=1
  1.  . D MSGADD(.LRMSG2)
  1.  D KILLDD(150.3)
  1.  D KILLDD(150.4)
  1.  D KILLDD(150.5)
  1.  D MSGADD("File #69.9 field data deletion finished")
  1.  D MSGADD("Post install completed"_$S(POSTERR:" with errors",1:"")_" at "_$$HTE^XLFDT($H))
  1.  ; D MSGADD("Sending install completion alert to mail group G.LMI")
  1.  ; Send alert
  1.  D ALERT("Installation of patch "_$G(XPDNM,"Unknown patch")_" completed on "_$$HTE^XLFDT($H)_$S(POSTERR:" with errors",1:""))
  1.  S RECIPS(DUZ)=""
  1.  D EMAIL("INSTALL COMPLETED:"_$G(XPDNM),"^TMP(""LR343"","_$J_",""MSG"")",.RECIPS)
  1.  D CLEAN
  1.  Q
  1.  ;
  1. ALERT(MSG) ;
  1.  N DA,DIK,XQA,XQAMSG
  1.  S MSG=$G(MSG)
  1.  S XQAMSG=MSG
  1.  S XQA("G.LMI")=""
  1.  ; D SETUP^XQALERT           ; IHS/MSC/MKK
  1.  Q
  1.  ;
  1. EMAIL(SUB,LRTXT,LRADDR) ;
  1.  ; Sends an email message via MailMan using installer's DUZ
  1.  ;    SUB <byval>   Subject for the message
  1.  ;  LRTXT <byval>   Closed root local or global array
  1.  ;              ie local array TEXT(1) passed as "TEXT"
  1.  ; LRADDR <byref>   MailMan compatable array of message recipients
  1.  N XMERR,XMZ,DIFROM
  1.  ; D SENDMSG^XMXAPI($G(DUZ),$G(SUB),$G(LRTXT),.LRADDR)
  1.  Q $G(XMZ,-1)
  1.  ;
  1. BLDBODY(STR,ARR) ;
  1.  ; Adds a string to the end of the passed array
  1.  ; Useful for building email message bodies
  1.  ; STR <req>    The string to add to the array
  1.  ; ARR <byref>  The array. Should be a simple, integer
  1.  ;              based subscript array ie X(1), X(2), etc.
  1.  N SUB
  1.  S STR=$G(STR)
  1.  S SUB=+$O(ARR("A"),-1)
  1.  S ARR(SUB+1)=STR
  1.  Q
  1.  ;
  1. GETVALS(NULL) ;
  1.  ; Returns the values for #69.9 fields 150.3,150.4,150.5
  1.  ; as a string  ie 000  or 010 etc (each field is only 1 or 0)
  1.  N NODE,LRDATA,LRERR,VALUES
  1.  S VALUES=""
  1.  D GETS^DIQ(69.9,"1,","150.3;150.4;150.5","I","LRDATA","LRERR")
  1.  I $D(LRDATA(69.9))>9 D  ;
  1.  . S NODE="LRDATA(69.9)"
  1.  .  F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,1)'=69.9  S VALUES=VALUES_+@NODE
  1.  Q VALUES
  1.  ;
  1. UPDTPROT(IEN) ;
  1.  ; Sets the PROTOCOL's (#101) DISABLE field (#2) to DISABLED
  1.  ; and its ENTRY ACTION field (#20) to Q (QUIT)
  1.  N LRFDA,LRMSG
  1.  S IEN=$G(IEN)
  1.  S LRFDA(1,101,IEN_",",2)="DISABLED BY LR*5.2*343"
  1.  S LRFDA(1,101,IEN_",",20)="Q"
  1.  D FILE^DIE("ET","LRFDA(1)","LRMSG")
  1.  Q
  1.  ;
  1. MSGADD(TXT,LB) ;
  1.  ; Utility to create a message global to save install
  1.  ; messages and send later, usually via mailman.  Useful
  1.  ; when an install is tasked.  It will print
  1.  ; the messages out as they come in, as well as save them
  1.  ; to the TMP global
  1.  ; Input
  1.  ; TXT <byref or byval>
  1.  ;         If $D(TXT)=1 then TXT is saved
  1.  ;         If $D(TXT)>9 then step through array and save each node 
  1.  ;         as separate line.
  1.  ;  LB <opt>   LineBreak  (True then uses MBES -- False uses MES)
  1.  ;
  1.  ; TXT <byref> is used by-ref when passsing in arrays created by
  1.  ; the FileMan MSG^DIALOG output array
  1.  ;
  1.  N NODE,SUB,POS
  1.  S TXT=$G(TXT)
  1.  S LB=$G(LB)
  1.  I LB="" S LB=1
  1.  S LB=+LB
  1.  S SUB=+$O(^TMP("LR343",$J,"MSG","A"),-1)
  1.  I $D(TXT)>9 D  ;
  1.  . S NODE="TXT"
  1.  . F  S NODE=$Q(@NODE) Q:NODE=""  D  ;
  1.  . . S ^TMP("LR343",$J,"MSG",SUB+1)=@NODE
  1.  . . S SUB=SUB+1
  1.  . . I $D(XPDENV) I LB D BMES^XPDUTL($$CJ^XLFSTR(@NODE,$G(IOM,80)))
  1.  . . I $D(XPDENV) I 'LB D MES^XPDUTL($$CJ^XLFSTR(@NODE,$G(IOM,80)))
  1.  . . ; I '$D(XPDENV) W !,$$CJ^XLFSTR(@NODE,$G(IOM,80))
  1.  . . I '$D(XPDENV) D BMES^XPDUTL($$CJ^XLFSTR(@NODE,$G(IOM,80)))      ; IHS/MSC/MKK
  1.  . ;
  1.  ;
  1.  I $D(TXT)=1 D  ;
  1.  . S ^TMP("LR343",$J,"MSG",SUB+1)=TXT
  1.  . I '$D(XPDENV) I LB D BMES^XPDUTL($$CJ^XLFSTR(TXT,$G(IOM,80)))
  1.  . I '$D(XPDENV) I 'LB D MES^XPDUTL($$CJ^XLFSTR(TXT,$G(IOM,80)))
  1.  . ; I $D(XPDENV) W !,$$CJ^XLFSTR(TXT,$G(IOM,80))
  1.  . I $D(XPDENV) D BMES^XPDUTL($$CJ^XLFSTR(TXT,$G(IOM,80)))           ; IHS/MSC/MKK
  1.  Q
  1.  ;
  1. CLEAN ;
  1.  ; K ^TMP("LR343",$J)
  1.  D CLEAN^DILF
  1.  Q
  1.  ;
  1. KILLDD(FIELD) ;
  1.  ; Deletes the #69.9 field's DD
  1.  N DIK,DA
  1.  S DIK="^DD(69.9,"
  1.  S DA=FIELD
  1.  S DA(1)=69.9
  1.  D ^DIK
  1.  Q
  1.  ;
  1.  ; ---- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1. BIGHONK ; EP - Big, Honking Warning Message
  1.  D PASSMESG("ATTENTION")
  1.  W !
  1.  W ?4,"This install must now pause for 5 minutes in order to let all existing",!
  1.  W ?4,"events clear so that ""Can't Return To Source"" errors do not occur when",!
  1.  W ?4,"the  LR70 MOVEMENT EVENT  and  LR70 MOVEMENT EVENT TASK  protocols are",!
  1.  W ?4,"modified.",!!
  1.  W ?4,"An error would cause the other chained events not to be processed.",!!
  1.  W ?4,"Your patience is appreciated. Pause begins NOW at ",$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ")),".",!
  1.  Q
  1.  ; 
  1. PASSMESG(WOT) ; EP -- Splash message
  1.  NEW CRTLINE,MAXIT,AROUND
  1.  ;
  1.  F CRTLINE=1:1:21 W $J("",80),!
  1.  D EN^XBVIDEO("HOM")
  1.  S MAXIT="@"
  1.  F J=1:1:$L(WOT) S MAXIT=MAXIT_$E(WOT,J,J)_"@"
  1.  S AROUND=$TR($J("",8+$L(MAXIT))," ","@")
  1.  S MAXIT="@@!!"_$TR(MAXIT," ","@")_"!!@@"
  1.  ;
  1.  W !!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(MAXIT,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  Q
  1.  ;
  1.  ; ---- END IHS/MSC/MKK - LR*5.2*1031