LR343 ;DALOI/JDB - LR*5.2*343 KIDS ROUTINE
;;5.2;LAB SERVICE;**343**;Sep 27, 1994;Build 1
;
; Send email if #69.9 fields set to Yes
; Set LR7O MOVEMENT EVENT protocols DISABLE and ACTION fields
; Pause X minutes so any running protocols can clear
; KIDS deletes LR7OEVNT routine
; KIDS deletes LR7O MOVEMENT EVENT protocols
; Delete data from #69.9 fields
; Delete #69.9 fields DD
;
;
EN ;
; Environment Check
; Does not prevent loading of the transport global.
;
D CLEAN
D CHECK
I $G(XPDQUIT) D Q ;
. W !,$$CJ^XLFSTR("Environment check failed",$G(IOM,80))
;
W !,$$CJ^XLFSTR("Environment is okay",$G(IOM,80))
D ALERT("Installation of patch "_$G(XPDNM,"Unknown patch")_" started on "_$$HTE^XLFDT($H))
I '$G(XPDENV) D Q
. D ALERT("Transport global for patch "_$G(XPDNM,"Unknown patch")_" loaded on "_$$HTE^XLFDT($H))
. D MSGADD("Sending transport global loaded alert to mail group G.LMI")
Q
;
CHECK ;
; Perform environment check
N POP
; Is Home device defined
; Need Home device so "task install" option is displayed
S POP=0 S IOP="",%ZIS=0 D ^%ZIS
I POP D Q
. S XPDQUIT=2
. W !,$$CJ^XLFSTR("*** Home device is not defined ***",$G(IOM,80))
;
; Device Defined
I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D Q
. W !,$$CJ^XLFSTR("*** Terminal Device is not defined ***",$G(IOM,80))
. S XPDQUIT=2
;
; DUZ setup
I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D Q
. W !,$$CJ^XLFSTR("*** Please log in to set variables ***",$G(IOM,80))
. S XPDQUIT=2
;
; Active User
I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D Q
. W !,$$CJ^XLFSTR("*** You are not a valid user on this system ***",$G(IOM,80))
. S XPDQUIT=2
;
; KIDS default answer to "Disable Protocols...."
S XPDDIQ("XPZ1")=0 ;;Dont allow disabling options
S XPDDIQ("XPZ1","B")="NO"
Q
;
PRE ;
; KIDS Pre Install
; Check that install was tasked
; Check if any File #69.9 fields are set to "YES" If so send
; notification email.
; Disable Lab Protocols (set DISABLED field and set ACTION to Q)
; Hang so current processes started by protocols can end
N IEN,ERR,PREERR,RECIPS,BODY,VALS,STR
S PREERR=0
D MSGADD("Pre install started at "_$$HTE^XLFDT($H))
;
; Was install tasked? Quit if not
I '$D(ZTQUEUED) I $G(IO("Q"))="" D Q
. S XPDQUIT=2
. S XPDABORT=2
. D MSGADD("*** THIS INSTALLATION MUST BE TASKED ***")
. D MSGADD("",0)
. D MSGADD("Refer to the Patch Installation instructions",0)
. D MSGADD("for details concerning re-running the install.",0)
. D CLEAN
;
; check DD field values and send email if any are YES
S VALS=$$GETVALS()
I VALS>0 D ;
. S STR="File #69.9 LABORATORY SITE has one or more fields that were set to YES."
. D BLDBODY(STR,.BODY)
. S STR=" #150.3 CANCEL ON ADMIT set to "_$S($E(VALS,1,1):"YES",1:"NO")
. D BLDBODY(STR,.BODY)
. S STR=" #150.4 CANCEL ON DISCHARGE set to "_$S($E(VALS,2,2):"YES",1:"NO")
. D BLDBODY(STR,.BODY)
. S STR=" #150.5 CANCEL ON SPECIALTY set to "_$S($E(VALS,3,3):"YES",1:"NO")
. D BLDBODY(STR,.BODY)
. D BLDBODY(" ",.BODY)
. 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."
. 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."
. S STR=STR_" Please check your configurations to ensure that this migration has occurred."
. D BLDBODY(STR,.BODY)
. S RECIPS(DUZ)=""
. S RECIPS("G.LMI")=""
. D EMAIL("LR*5.2*343 -- 69.9 DC Fields","BODY",.RECIPS)
. K BODY
. D MSGADD("*** File #69.9 field(s) set to YES ***")
;
D ALERT("LR*5.2*343 Installation has started")
D MSGADD("Sent install started alert to mail group G.LMI")
;
; Disable Protocols and set action event to quit
D MSGADD("Setting DISABLE and ACTION fields for Protocols")
S IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT","B",,"ERR")
I IEN D UPDTPROT(IEN)
I 'IEN D MSGADD("*** Did not find LR7O MOVEMENT EVENT PROTOCOL ***")
S IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT TASK","B",,"ERR")
I IEN D UPDTPROT(IEN)
I 'IEN D MSGADD("*** Did not find LR7O MOVEMENT EVENT TASK PROTOCOL ***")
;
; Now hang for X minutes to let all existing triggered
; events to clear so we don't cause any "cant return to source"
; errors when we overwrite the protocl's routine which would
; cause the other chained events not to be processed (the hang is
; why the install is tasked and not run in direct mode)
H 300
;
I 'PREERR D MSGADD("No actions required for pre install")
D MSGADD("Pre install completed at "_$$HTE^XLFDT($H))
Q
;
POST ;
; KIDS Post Install
; Delete data in File #69.9 fields
; Remove #69.9 fields from Data Dictionary
; Email installation progress message
N DA,DIK,LRFDA,LRMSG,LRMSG2,POSTERR,RECIPS
S POSTERR=0
D MSGADD("Post install started at "_$$HTE^XLFDT($H))
D MSGADD("File #69.9 field data update started")
; delete #69.9 field data
S LRFDA(1,69.9,"1,",150.3)="@"
S LRFDA(1,69.9,"1,",150.4)="@"
S LRFDA(1,69.9,"1,",150.5)="@"
K MSG
D FILE^DIE("","LRFDA(1)","LRMSG")
I $D(LRMSG) D ;
. K LRMSG2
. D MSG^DIALOG("ASEM",.LRMSG2,$G(IOM,80),,"LRMSG")
. S POSTERR=1
. D MSGADD(.LRMSG2)
D KILLDD(150.3)
D KILLDD(150.4)
D KILLDD(150.5)
D MSGADD("File #69.9 field data deletion finished")
D MSGADD("Post install completed"_$S(POSTERR:" with errors",1:"")_" at "_$$HTE^XLFDT($H))
D MSGADD("Sending install completion alert to mail group G.LMI")
; Send alert
D ALERT("Installation of patch "_$G(XPDNM,"Unknown patch")_" completed on "_$$HTE^XLFDT($H)_$S(POSTERR:" with errors",1:""))
S RECIPS(DUZ)=""
D EMAIL("INSTALL COMPLETED:"_$G(XPDNM),"^TMP(""LR343"","_$J_",""MSG"")",.RECIPS)
D CLEAN
Q
;
ALERT(MSG) ;
N DA,DIK,XQA,XQAMSG
S MSG=$G(MSG)
S XQAMSG=MSG
S XQA("G.LMI")=""
D SETUP^XQALERT
Q
;
EMAIL(SUB,LRTXT,LRADDR) ;
; Sends an email message via MailMan using installer's DUZ
; SUB <byval> Subject for the message
; LRTXT <byval> Closed root local or global array
; ie local array TEXT(1) passed as "TEXT"
; LRADDR <byref> MailMan compatable array of message recipients
N XMERR,XMZ,DIFROM
D SENDMSG^XMXAPI($G(DUZ),$G(SUB),$G(LRTXT),.LRADDR)
Q $G(XMZ,-1)
;
BLDBODY(STR,ARR) ;
; Adds a string to the end of the passed array
; Useful for building email message bodies
; STR <req> The string to add to the array
; ARR <byref> The array. Should be a simple, integer
; based subscript array ie X(1), X(2), etc.
N SUB
S STR=$G(STR)
S SUB=+$O(ARR("A"),-1)
S ARR(SUB+1)=STR
Q
;
GETVALS(NULL) ;
; Returns the values for #69.9 fields 150.3,150.4,150.5
; as a string ie 000 or 010 etc (each field is only 1 or 0)
N NODE,LRDATA,LRERR,VALUES
S VALUES=""
D GETS^DIQ(69.9,"1,","150.3;150.4;150.5","I","LRDATA","LRERR")
I $D(LRDATA(69.9))>9 D ;
. S NODE="LRDATA(69.9)"
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,1)'=69.9 S VALUES=VALUES_+@NODE
Q VALUES
;
UPDTPROT(IEN) ;
; Sets the PROTOCOL's (#101) DISABLE field (#2) to DISABLED
; and its ENTRY ACTION field (#20) to Q (QUIT)
N LRFDA,LRMSG
S IEN=$G(IEN)
S LRFDA(1,101,IEN_",",2)="DISABLED BY LR*5.2*343"
S LRFDA(1,101,IEN_",",20)="Q"
D FILE^DIE("ET","LRFDA(1)","LRMSG")
Q
;
MSGADD(TXT,LB) ;
; Utility to create a message global to save install
; messages and send later, usually via mailman. Useful
; when an install is tasked. It will print
; the messages out as they come in, as well as save them
; to the TMP global
; Input
; TXT <byref or byval>
; If $D(TXT)=1 then TXT is saved
; If $D(TXT)>9 then step through array and save each node
; as separate line.
; LB <opt> LineBreak (True then uses MBES -- False uses MES)
;
; TXT <byref> is used by-ref when passsing in arrays created by
; the FileMan MSG^DIALOG output array
;
N NODE,SUB,POS
S TXT=$G(TXT)
S LB=$G(LB)
I LB="" S LB=1
S LB=+LB
S SUB=+$O(^TMP("LR343",$J,"MSG","A"),-1)
I $D(TXT)>9 D ;
. S NODE="TXT"
. F S NODE=$Q(@NODE) Q:NODE="" D ;
. . S ^TMP("LR343",$J,"MSG",SUB+1)=@NODE
. . S SUB=SUB+1
. . I $D(XPDENV) I LB D BMES^XPDUTL($$CJ^XLFSTR(@NODE,$G(IOM,80)))
. . I $D(XPDENV) I 'LB D MES^XPDUTL($$CJ^XLFSTR(@NODE,$G(IOM,80)))
. . I '$D(XPDENV) W !,$$CJ^XLFSTR(@NODE,$G(IOM,80))
. ;
;
I $D(TXT)=1 D ;
. S ^TMP("LR343",$J,"MSG",SUB+1)=TXT
. I '$D(XPDENV) I LB D BMES^XPDUTL($$CJ^XLFSTR(TXT,$G(IOM,80)))
. I '$D(XPDENV) I 'LB D MES^XPDUTL($$CJ^XLFSTR(TXT,$G(IOM,80)))
. I $D(XPDENV) W !,$$CJ^XLFSTR(TXT,$G(IOM,80))
Q
;
CLEAN ;
K ^TMP("LR343",$J)
D CLEAN^DILF
Q
;
KILLDD(FIELD) ;
; Deletes the #69.9 field's DD
N DIK,DA
S DIK="^DD(69.9,"
S DA=FIELD
S DA(1)=69.9
D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR343 8992 printed Nov 22, 2024@17:13:59 Page 2
LR343 ;DALOI/JDB - LR*5.2*343 KIDS ROUTINE
+1 ;;5.2;LAB SERVICE;**343**;Sep 27, 1994;Build 1
+2 ;
+3 ; Send email if #69.9 fields set to Yes
+4 ; Set LR7O MOVEMENT EVENT protocols DISABLE and ACTION fields
+5 ; Pause X minutes so any running protocols can clear
+6 ; KIDS deletes LR7OEVNT routine
+7 ; KIDS deletes LR7O MOVEMENT EVENT protocols
+8 ; Delete data from #69.9 fields
+9 ; Delete #69.9 fields DD
+10 ;
+11 ;
EN ;
+1 ; Environment Check
+2 ; Does not prevent loading of the transport global.
+3 ;
+4 DO CLEAN
+5 DO CHECK
+6 ;
IF $GET(XPDQUIT)
Begin DoDot:1
+7 WRITE !,$$CJ^XLFSTR("Environment check failed",$GET(IOM,80))
End DoDot:1
QUIT
+8 ;
+9 WRITE !,$$CJ^XLFSTR("Environment is okay",$GET(IOM,80))
+10 DO ALERT("Installation of patch "_$GET(XPDNM,"Unknown patch")_" started on "_$$HTE^XLFDT($HOROLOG))
+11 IF '$GET(XPDENV)
Begin DoDot:1
+12 DO ALERT("Transport global for patch "_$GET(XPDNM,"Unknown patch")_" loaded on "_$$HTE^XLFDT($HOROLOG))
+13 DO MSGADD("Sending transport global loaded alert to mail group G.LMI")
End DoDot:1
QUIT
+14 QUIT
+15 ;
CHECK ;
+1 ; Perform environment check
+2 NEW POP
+3 ; Is Home device defined
+4 ; Need Home device so "task install" option is displayed
+5 SET POP=0
SET IOP=""
SET %ZIS=0
DO ^%ZIS
+6 IF POP
Begin DoDot:1
+7 SET XPDQUIT=2
+8 WRITE !,$$CJ^XLFSTR("*** Home device is not defined ***",$GET(IOM,80))
End DoDot:1
QUIT
+9 ;
+10 ; Device Defined
+11 IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
Begin DoDot:1
+12 WRITE !,$$CJ^XLFSTR("*** Terminal Device is not defined ***",$GET(IOM,80))
+13 SET XPDQUIT=2
End DoDot:1
QUIT
+14 ;
+15 ; DUZ setup
+16 IF $SELECT('$GET(DUZ):1,$DATA(DUZ)[0:1,$DATA(DUZ(0))[0:1,1:0)
Begin DoDot:1
+17 WRITE !,$$CJ^XLFSTR("*** Please log in to set variables ***",$GET(IOM,80))
+18 SET XPDQUIT=2
End DoDot:1
QUIT
+19 ;
+20 ; Active User
+21 IF $PIECE($$ACTIVE^XUSER(DUZ),"^")'=1
Begin DoDot:1
+22 WRITE !,$$CJ^XLFSTR("*** You are not a valid user on this system ***",$GET(IOM,80))
+23 SET XPDQUIT=2
End DoDot:1
QUIT
+24 ;
+25 ; KIDS default answer to "Disable Protocols...."
+26 ;;Dont allow disabling options
SET XPDDIQ("XPZ1")=0
+27 SET XPDDIQ("XPZ1","B")="NO"
+28 QUIT
+29 ;
PRE ;
+1 ; KIDS Pre Install
+2 ; Check that install was tasked
+3 ; Check if any File #69.9 fields are set to "YES" If so send
+4 ; notification email.
+5 ; Disable Lab Protocols (set DISABLED field and set ACTION to Q)
+6 ; Hang so current processes started by protocols can end
+7 NEW IEN,ERR,PREERR,RECIPS,BODY,VALS,STR
+8 SET PREERR=0
+9 DO MSGADD("Pre install started at "_$$HTE^XLFDT($HOROLOG))
+10 ;
+11 ; Was install tasked? Quit if not
+12 IF '$DATA(ZTQUEUED)
IF $GET(IO("Q"))=""
Begin DoDot:1
+13 SET XPDQUIT=2
+14 SET XPDABORT=2
+15 DO MSGADD("*** THIS INSTALLATION MUST BE TASKED ***")
+16 DO MSGADD("",0)
+17 DO MSGADD("Refer to the Patch Installation instructions",0)
+18 DO MSGADD("for details concerning re-running the install.",0)
+19 DO CLEAN
End DoDot:1
QUIT
+20 ;
+21 ; check DD field values and send email if any are YES
+22 SET VALS=$$GETVALS()
+23 ;
IF VALS>0
Begin DoDot:1
+24 SET STR="File #69.9 LABORATORY SITE has one or more fields that were set to YES."
+25 DO BLDBODY(STR,.BODY)
+26 SET STR=" #150.3 CANCEL ON ADMIT set to "_$SELECT($EXTRACT(VALS,1,1):"YES",1:"NO")
+27 DO BLDBODY(STR,.BODY)
+28 SET STR=" #150.4 CANCEL ON DISCHARGE set to "_$SELECT($EXTRACT(VALS,2,2):"YES",1:"NO")
+29 DO BLDBODY(STR,.BODY)
+30 SET STR=" #150.5 CANCEL ON SPECIALTY set to "_$SELECT($EXTRACT(VALS,3,3):"YES",1:"NO")
+31 DO BLDBODY(STR,.BODY)
+32 DO BLDBODY(" ",.BODY)
+33 SET 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."
+34 SET 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."
+35 SET STR=STR_" Please check your configurations to ensure that this migration has occurred."
+36 DO BLDBODY(STR,.BODY)
+37 SET RECIPS(DUZ)=""
+38 SET RECIPS("G.LMI")=""
+39 DO EMAIL("LR*5.2*343 -- 69.9 DC Fields","BODY",.RECIPS)
+40 KILL BODY
+41 DO MSGADD("*** File #69.9 field(s) set to YES ***")
End DoDot:1
+42 ;
+43 DO ALERT("LR*5.2*343 Installation has started")
+44 DO MSGADD("Sent install started alert to mail group G.LMI")
+45 ;
+46 ; Disable Protocols and set action event to quit
+47 DO MSGADD("Setting DISABLE and ACTION fields for Protocols")
+48 SET IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT","B",,"ERR")
+49 IF IEN
DO UPDTPROT(IEN)
+50 IF 'IEN
DO MSGADD("*** Did not find LR7O MOVEMENT EVENT PROTOCOL ***")
+51 SET IEN=$$FIND1^DIC(101,,"XO","LR7O MOVEMENT EVENT TASK","B",,"ERR")
+52 IF IEN
DO UPDTPROT(IEN)
+53 IF 'IEN
DO MSGADD("*** Did not find LR7O MOVEMENT EVENT TASK PROTOCOL ***")
+54 ;
+55 ; Now hang for X minutes to let all existing triggered
+56 ; events to clear so we don't cause any "cant return to source"
+57 ; errors when we overwrite the protocl's routine which would
+58 ; cause the other chained events not to be processed (the hang is
+59 ; why the install is tasked and not run in direct mode)
+60 HANG 300
+61 ;
+62 IF 'PREERR
DO MSGADD("No actions required for pre install")
+63 DO MSGADD("Pre install completed at "_$$HTE^XLFDT($HOROLOG))
+64 QUIT
+65 ;
POST ;
+1 ; KIDS Post Install
+2 ; Delete data in File #69.9 fields
+3 ; Remove #69.9 fields from Data Dictionary
+4 ; Email installation progress message
+5 NEW DA,DIK,LRFDA,LRMSG,LRMSG2,POSTERR,RECIPS
+6 SET POSTERR=0
+7 DO MSGADD("Post install started at "_$$HTE^XLFDT($HOROLOG))
+8 DO MSGADD("File #69.9 field data update started")
+9 ; delete #69.9 field data
+10 SET LRFDA(1,69.9,"1,",150.3)="@"
+11 SET LRFDA(1,69.9,"1,",150.4)="@"
+12 SET LRFDA(1,69.9,"1,",150.5)="@"
+13 KILL MSG
+14 DO FILE^DIE("","LRFDA(1)","LRMSG")
+15 ;
IF $DATA(LRMSG)
Begin DoDot:1
+16 KILL LRMSG2
+17 DO MSG^DIALOG("ASEM",.LRMSG2,$GET(IOM,80),,"LRMSG")
+18 SET POSTERR=1
+19 DO MSGADD(.LRMSG2)
End DoDot:1
+20 DO KILLDD(150.3)
+21 DO KILLDD(150.4)
+22 DO KILLDD(150.5)
+23 DO MSGADD("File #69.9 field data deletion finished")
+24 DO MSGADD("Post install completed"_$SELECT(POSTERR:" with errors",1:"")_" at "_$$HTE^XLFDT($HOROLOG))
+25 DO MSGADD("Sending install completion alert to mail group G.LMI")
+26 ; Send alert
+27 DO ALERT("Installation of patch "_$GET(XPDNM,"Unknown patch")_" completed on "_$$HTE^XLFDT($HOROLOG)_$SELECT(POSTERR:" with errors",1:""))
+28 SET RECIPS(DUZ)=""
+29 DO EMAIL("INSTALL COMPLETED:"_$GET(XPDNM),"^TMP(""LR343"","_$JOB_",""MSG"")",.RECIPS)
+30 DO CLEAN
+31 QUIT
+32 ;
ALERT(MSG) ;
+1 NEW DA,DIK,XQA,XQAMSG
+2 SET MSG=$GET(MSG)
+3 SET XQAMSG=MSG
+4 SET XQA("G.LMI")=""
+5 DO SETUP^XQALERT
+6 QUIT
+7 ;
EMAIL(SUB,LRTXT,LRADDR) ;
+1 ; Sends an email message via MailMan using installer's DUZ
+2 ; SUB <byval> Subject for the message
+3 ; LRTXT <byval> Closed root local or global array
+4 ; ie local array TEXT(1) passed as "TEXT"
+5 ; LRADDR <byref> MailMan compatable array of message recipients
+6 NEW XMERR,XMZ,DIFROM
+7 DO SENDMSG^XMXAPI($GET(DUZ),$GET(SUB),$GET(LRTXT),.LRADDR)
+8 QUIT $GET(XMZ,-1)
+9 ;
BLDBODY(STR,ARR) ;
+1 ; Adds a string to the end of the passed array
+2 ; Useful for building email message bodies
+3 ; STR <req> The string to add to the array
+4 ; ARR <byref> The array. Should be a simple, integer
+5 ; based subscript array ie X(1), X(2), etc.
+6 NEW SUB
+7 SET STR=$GET(STR)
+8 SET SUB=+$ORDER(ARR("A"),-1)
+9 SET ARR(SUB+1)=STR
+10 QUIT
+11 ;
GETVALS(NULL) ;
+1 ; Returns the values for #69.9 fields 150.3,150.4,150.5
+2 ; as a string ie 000 or 010 etc (each field is only 1 or 0)
+3 NEW NODE,LRDATA,LRERR,VALUES
+4 SET VALUES=""
+5 DO GETS^DIQ(69.9,"1,","150.3;150.4;150.5","I","LRDATA","LRERR")
+6 ;
IF $DATA(LRDATA(69.9))>9
Begin DoDot:1
+7 SET NODE="LRDATA(69.9)"
+8 FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,1)'=69.9
QUIT
SET VALUES=VALUES_+@NODE
End DoDot:1
+9 QUIT VALUES
+10 ;
UPDTPROT(IEN) ;
+1 ; Sets the PROTOCOL's (#101) DISABLE field (#2) to DISABLED
+2 ; and its ENTRY ACTION field (#20) to Q (QUIT)
+3 NEW LRFDA,LRMSG
+4 SET IEN=$GET(IEN)
+5 SET LRFDA(1,101,IEN_",",2)="DISABLED BY LR*5.2*343"
+6 SET LRFDA(1,101,IEN_",",20)="Q"
+7 DO FILE^DIE("ET","LRFDA(1)","LRMSG")
+8 QUIT
+9 ;
MSGADD(TXT,LB) ;
+1 ; Utility to create a message global to save install
+2 ; messages and send later, usually via mailman. Useful
+3 ; when an install is tasked. It will print
+4 ; the messages out as they come in, as well as save them
+5 ; to the TMP global
+6 ; Input
+7 ; TXT <byref or byval>
+8 ; If $D(TXT)=1 then TXT is saved
+9 ; If $D(TXT)>9 then step through array and save each node
+10 ; as separate line.
+11 ; LB <opt> LineBreak (True then uses MBES -- False uses MES)
+12 ;
+13 ; TXT <byref> is used by-ref when passsing in arrays created by
+14 ; the FileMan MSG^DIALOG output array
+15 ;
+16 NEW NODE,SUB,POS
+17 SET TXT=$GET(TXT)
+18 SET LB=$GET(LB)
+19 IF LB=""
SET LB=1
+20 SET LB=+LB
+21 SET SUB=+$ORDER(^TMP("LR343",$JOB,"MSG","A"),-1)
+22 ;
IF $DATA(TXT)>9
Begin DoDot:1
+23 SET NODE="TXT"
+24 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:2
+25 SET ^TMP("LR343",$JOB,"MSG",SUB+1)=@NODE
+26 SET SUB=SUB+1
+27 IF $DATA(XPDENV)
IF LB
DO BMES^XPDUTL($$CJ^XLFSTR(@NODE,$GET(IOM,80)))
+28 IF $DATA(XPDENV)
IF 'LB
DO MES^XPDUTL($$CJ^XLFSTR(@NODE,$GET(IOM,80)))
+29 IF '$DATA(XPDENV)
WRITE !,$$CJ^XLFSTR(@NODE,$GET(IOM,80))
End DoDot:2
+30 ;
End DoDot:1
+31 ;
+32 ;
IF $DATA(TXT)=1
Begin DoDot:1
+33 SET ^TMP("LR343",$JOB,"MSG",SUB+1)=TXT
+34 IF '$DATA(XPDENV)
IF LB
DO BMES^XPDUTL($$CJ^XLFSTR(TXT,$GET(IOM,80)))
+35 IF '$DATA(XPDENV)
IF 'LB
DO MES^XPDUTL($$CJ^XLFSTR(TXT,$GET(IOM,80)))
+36 IF $DATA(XPDENV)
WRITE !,$$CJ^XLFSTR(TXT,$GET(IOM,80))
End DoDot:1
+37 QUIT
+38 ;
CLEAN ;
+1 KILL ^TMP("LR343",$JOB)
+2 DO CLEAN^DILF
+3 QUIT
+4 ;
KILLDD(FIELD) ;
+1 ; Deletes the #69.9 field's DD
+2 NEW DIK,DA
+3 SET DIK="^DD(69.9,"
+4 SET DA=FIELD
+5 SET DA(1)=69.9
+6 DO ^DIK
+7 QUIT
