BLRUTIL3 ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 04-Apr-2016 14:28 ; MKK
;;5.2;IHS LABORATORY;**1025,1027,1030,1031,1033,1039**;NOV 01, 1997;Build 38
;
Q
;
; ----- BEGIN IHS/OIT/MKK LR*5.2*1025
GETACCCP(LRAS,LRAA,LRAD,LRAN) ; EP -- Take Accession # & break apart
; Parse and process user input. Cloned from LRWU4.
NEW LRIDIV,LRQUIT,LRX,X1,X2,X3
S LRX=LRAS
;
S (LRAA,LRAD,LRAN)=""
;
S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
S:X3=""&(+X2=X2) X3=X2,X2=""
I X1'?1A.AN Q 0
;
S LRAA=$O(^LRO(68,"B",X1,0))
I LRAA<1 Q 0
;
; S %=$P(^LRO(68,LRAA,0),U,14) ; Don't bother with Security Check
; I $L(%),'$D(^XUSEC(%,DUZ)) Q 0 ; Don't bother with Security Check
;
S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
;
; Only accession area identifier, no date or number
I X2="",X3="" D
. N %DT
. S %DT="AP",%DT("A")=" Accession Date: ",%DT("B")="TODAY"
. ; D DATE^LRWU
. ; D DATE
. I $D(DUOUT) Q
. I Y<1 Q
. S LRAD=Y
;
; Convert middle value to FileMan date
; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
; number as middle part of accession then convert to appropriate date.
I +$G(LRAD)<1 D
. N %DT
. I X2="" S X2=DT
. I X2?4N D
. . S X2=$E(DT,1,3)_X2
. . I X2>DT S X2=X2-10000
. S %DT="P",X=X2
. D ^%DT
. I Y>0 S LRAD=Y Q
I +$G(LRAD)<1 Q 0
;
; Convert date entered to apropriate date for accession area transform
S X=$P(^LRO(68,LRAA,0),U,3)
S LRAD=$S("D"[X:LRAD,X="Y":$E(LRAD,1,3)_"0000","M"[X:$E(LRAD,1,5)_"00","Q"[X:$E(LRAD,1,3)_"0000"+(($E(LRAD,4,5)-1)\3*300+100),1:LRAD)
; W:X3>0 " ",+X3
;
I X3="",$D(LRACC) D
. N DIR,DIRUT,DUOUT,DTOUT,X,Y
. S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
. D ^DIR
. I Y=""!$D(DIRUT) Q
. S X3=Y
;
I X3="",$D(LRACC) Q 0
S LRAN=+X3
Q 1
;
DATE ; EP
K DTOUT,DUOUT S LREND=0
; W !,"DATE",!!,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B"),1:"TODAY"),"//" R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 I $D(DUOUT)!($D(DTOUT)) S LREND=1,Y=-1 Q
S:X="" X=$S($D(%DT("B")):%DT("B"),1:"T") S:$D(%DT)[0 %DT="E" S:%DT["A" %DT=$P(%DT,"A",1)_$P(%DT,"A",2) S:%DT'["E" %DT="E"_%DT D ^%DT G DATE:X="?"!(Y<1)
K %DT
Q
;
D2HBOLD(STR) ; EP - Write string DOUBLE HEIGHT & BOLDED
W !
W *27,"#3",*27,"[1m",STR,!
W *27,"#4",*27,"[1m",STR,!
W *27,"[0m",! ; Turn OFF all attributes
Q
;
BOLDUNDR(STR) ; EP -- Write string BOLDED & UNDERLINED
W *27,"[1;4m",STR,*27,"[0m"
Q
;
REVIDEO(STR) ; EP -- Write string in Reverse Video & BOLDED
W *27,"[1;7m",STR,*27,"[0m"
Q
; ----- END IHS/OIT/MKK LR*5.2*1025
;
; ----- BEGIN IHS/OIT/MKK LR*5.2*1027
ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.
NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB
NEW REVSTS
;
; If E-SIG not turned on, Quit
I '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$G(DUZ(2))) Q
;
S DOCIEN=$O(^VA(200,"B",LRDOC,"")) ; LRDOC = Ordering Provider
;
; If no IEN, Quit. Usually happens when LRDOC="Unknown"
Q:$G(DOCIEN)=""
;
I '($D(^BLRALAB(9009027.1,DOCIEN,0))#2) W ?56,"NOT E-SIG PARTICIPATING" Q
I $P(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A" W ?53,"INACTIVE E-SIG PARTICIPANT" Q
;
;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.
S:$G(LRSS)="" LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
;
S ESIGDSTR=$G(^LR(LRDFN,LRSS,LRIDT,9009027)) ; E-SIG string Data
;
Q:$P(ESIGDSTR,U,2)="" ; NO Signing Physician
Q:$P(^BLRALAB(9009027.1,$P(ESIGDSTR,U,2),0),U,7)'="A" ; NOT Active
;
; REVIEW status Data Values
S REVIEWDV=$$UP^XLFSTR($P($G(^DD(63.04,.9009025,0)),U,3))
S REVSTS=$P($P(REVIEWDV,$P(ESIGDSTR,U)_":",2),";")
;
; Make sure E-SIG STATUS is flush right
S TAB=IOM-(16+$L(REVSTS))
W ?TAB,"E-SIG STATUS: ",REVSTS
;
Q:'$P(ESIGDSTR,U,5) ; NO Signed Date
;
Q:REVSTS["NOT REV" ; NOT Reviewed
;
W !?5,"SIGNING PHYSICIAN: "
W $P($G(^VA(200,$P(ESIGDSTR,U,2),0)),U)
W !?5,"DATE/TIME RESULT SIGNED: "
W $TR($$FMTE^XLFDT($P(ESIGDSTR,U,5),"2MZ"),"@"," ")
Q
;
BLINKER(STR) ; EP -- Write string in BOLDED, UNDERLINED, & BLINKING
W *27,"[1;4;5m",STR,*27,"[0m"
Q
;
; Cloned from LR7OSAP1. Wrap Text in array to ^TMP global
WRAP(ROOT,FMT) ; EP - Wrap text
I '$L($G(ROOT)) Q ""
N CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X
S:'$G(FMT) FMT=79
S LRINDX=0,LRI=0,GCNT=0
K ^TMP("BLRUTIL3",$J)
F S LRI=$O(@ROOT@(LRI)) Q:LRI'>0 D
. S X=$S($L($G(@ROOT@(LRI))):@ROOT@(LRI),$L($G(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:""),LRINDX=LRINDX+1
. S X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)
S LRI=0
F S LRI=$O(LRTX(LRI)) Q:'LRI D LN^LR7OSAP S ^TMP("BLRUTIL3",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))
Q
;
;
ALERT ; EP
W !!
W "Patient Name:",$P(XQADATA,"^"),!
W " UID:",$P(XQADATA,"^",2),!
W " TEST:",$P(XQADATA,"^",3),!!
Q
; ----- END IHS/OIT/MKK LR*5.2*1027
;
; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
REVBLINK(STR) ; EP - Print string in Bold, Blinking, Reverse Video
W *27,"[1;7;5m",STR,*27,"[0m"
Q
;
; Moved PCC Bulletin code to here in order to standardize messages
; BLRBUL=1 SENDS BLRTXLOG BULLETIN
; BLRBUL=2 SENDS BLRTXLOGERR BULLETIN
; BLRBUL=3 SENDS BLRTXLOG AND BLRTXLOGERR BULLETIN
BULTNS ; EP - Send PCC Bulletin
Q:BLRPCC["Lab deleted test" ; If Lab Deleted Test, don't send message.
;
I "13"[BLRBUL D BULTX("BLRTXLOG") Q:BLRBUL=1
D BULTX("BLRTXLOGERR")
Q
;
BULTX(BULLETIN) ; EP - SEND BULLETIN IF PCC ERROR IN FILING
K XMB ; Initialize array
S Y="" ; Initialize variable
;
; If BLRTXLOG number exists, use ^BLRTXLOG database
I +$G(BLRLOGDA)>0 D BULTXSET
;
; If BLRTXLOG number DOES NOT exist, use variables
I +$G(BLRLOGDA)<1 D BLTXNSET
;
S XMB(7)=$G(BLRLOGDA) ; BLR Transaction Log Number
;
S XMB(8)=BLRPCC ; Error Message
;
S XMB=BULLETIN ; Bulletin to use
;
; Send the Bulletin
; S BLRDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=BLRDUZ
S XMDUZ="Lab to PCC Link Processor"
D ^XMB
;
; Clean up
K XMB
Q
;
; Set bulletin parameters from ^BLRTXLOG global
BULTXSET ; EP
NEW COLLDT,LABTIEN,PTPTR
;
S PTPTR=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",4) ; Patient Pointer
;
S XMB(1)=$P($G(^DPT(PTPTR,0)),"^",1) ; Patient Name
S XMB(2)=$G(^DPT(PTPTR,"LR")) ; LRDFN
;
; Date of Visit -- Collection Date
S COLLDT=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",1)
S XMB(3)=$$FMTE^XLFDT(COLLDT,"1D")
;
S XMB(4)=$P($G(^BLRTXLOG(BLRLOGDA,11)),"^",3) ; Order Number
S XMB(5)=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",2) ; Accession Number
;
S LABTIEN=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",6)
S XMB(6)=$P($G(^LAB(60,LABTIEN,0)),"^",1) ; Lab Test
;
Q
;
; Set bulletin parameters from variables
BLTXNSET ; EP
NEW PTPTR
;
S PTPTR=+$G(APCDALVR("APCDPAT")) ; Patient Pointer
;
S XMB(1)=$P($G(^DPT(PTPTR,0)),"^",1) ; Patient Name
S XMB(2)=$G(^DPT(PTPTR,"LR")) ; LRDFN
;
; Visit/Collection Date
S XMB(3)=$$FMTE^XLFDT($G(APCDALVR("APCDDATE")),"1D")
;
S XMB(4)=$G(BLRORD) ; Order Number
S XMB(5)=$G(BLRACCN) ; Accession Number
S XMB(6)=$P($G(^LAB(60,+$G(BLRTEST),0)),"^",1) ; Test Description
;
Q
;
; Get Reference Range for a Test for File 63
; Used by MEAG Delta Check
GETREFR(TESTNAME) ; EP
NEW IEN,MESSAGE,REFL,REFH,SPEC,TARGET,UNITS
;
; Get Internal Entry Number of Test
D FIND^DIC(60,,,,TESTNAME,,,,,"TARGET","MESSAGE")
S IEN=+$G(TARGET("DILIST",2,1))
Q:IEN<1 "!!!!!!!!"
;
S SPEC=+$O(^LAB(60,IEN,1,0)) ; First Site/Spec
Q:SPEC<1 "!!!!!!!!"
;
S REFL=$$GET1^DIQ(60.01,SPEC_","_IEN_",",1,"I")
S REFH=$$GET1^DIQ(60.01,SPEC_","_IEN_",",2,"I")
S UNITS=$$GET1^DIQ(60.01,SPEC_","_IEN_",",6,"I")
;
; If UNITS is a pointer to the IHS UCUM file, get units text
S:+$G(UNITS)>0 UNITS=$P($G(^BLRUCUM(UNITS,0)),"^")
;
Q SPEC_"!"_REFL_"!"_REFH_"!!!!"_UNITS_"!!"
;
INSTLRPT ; EP -- Report of ^BLRINSTL global
NEW CP,CNT,WHO,WHEN
NEW HEADER,PG,LINES,MAXLINES,QFLG,HD1
;
D INSTLRPI
;
F S CP=$O(^BLRINSTL("LAB PATCH",CP)) Q:CP<1!(QFLG="Q") D
. F S CNT=$O(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT)) Q:CNT<1!(QFLG="Q") D
.. D INSTLRPL
Q
;
INSTLRPI ; EP -- Initialize variables
NEW DTRANGE,FIRST,FIRSTDT,FRSTPTCH,LAST,LASTPTCH
S HEADER(1)="IHS LAB Patches Report"
;
S FRSTPTCH=$O(^BLRINSTL("LAB PATCH",0))
S FIRST=$O(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))
S FIRSTDT=$P($G(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")
;
S LASTPTCH=$O(^BLRINSTL("LAB PATCH","A"),-1)
S LAST=$O(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)
S LASTDT=$P($G(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")
;
S HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT
S HEADER(3)=" "
S $E(HEADER(4),5)="Patch"
S $E(HEADER(4),15)="Who"
S $E(HEADER(4),45)="When"
;
S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"
S (CP,CNT)=0
Q
;
INSTLRPL ; EP -- Line of Data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
W ?4,CP
W ?14,$G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
W ?44,$TR($P($G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")
W !
S LINES=LINES+1
Q
;
MAKE132 ; EP - Force Screen to 132 Characters
W "Setting display to 132 column mode",!
W $C(27)_"[?3h",!
W "132 column mode active.",!
W $TR($J("",132)," ","*"),!
W !
S IOM=132
Q
;
MAKE80 ; EP - Force Screen to 80 Characters
W "Setting display to 80 column mode",!
W $C(27)_"[?3l",!
W "80 column mode active.",!
W $TR($J("",80)," ","*"),!
W !
S IOM=80
Q
;
; MAILALMI(MESSAGE,MSGARRAY,FROMWHOM) ; EP - send e-MAIL and an Alert to members of the LMI Mail Group
MAILALMI(MESSAGE,MSGARRAY,FROMWHOM,NOUSER) ; EP - IHS/MSC/MKK - LR*5.2*1031 adds the NOUSER parameter
NEW MAILARRY
;
; Alert just sends MESSAGE string
; D SNDALERT(MESSAGE)
D SNDALERT(MESSAGE,$G(NOUSER)) ; IHS/MSC/MKK - LR*5.2*1031
;
; Setup variables for sending MailMan e-mail
I $L($G(MSGARRAY(1))) M MAILARRY=MSGARRAY
;
I $L($G(MSGARRAY(1)))<1 D ; If MSGARRAY null, create generic array
. S MAILARRY(1)="The Subject of this email is the message:"
. S MAILARRY(2)=" "_MESSAGE
;
I $G(FROMWHOM)="" S FROMWHOM="RPMS Lab Package"
;
; D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM)
D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM,$G(NOUSER)) ; IHS/MSC/MKK - LR*5.2*1031
;
I $D(^XTMP("BLRUTIL3"))<1 D
. S ^XTMP("BLRUTIL3",0)=$$HTFM^XLFDT(+$H+30)_"^"_$$HTFM^XLFDT(+$H)_"^MAILALMI Usage"
; M ^XTMP("BLRUTIL3","MAILALMI",$H,"DUZ")=DUZ
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
NEW NOW
S NOW=$H
S ^XTMP("BLRUTIL3","MAILALMI",NOW)=$$HTE^XLFDT(NOW,"5MZ")
M ^XTMP("BLRUTIL3","MAILALMI",NOW,"DUZ")=DUZ
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
Q
;
; SNDALERT(ALERTMSG,NOUSER) ; EP - Send alert to LMI group AND User (if not member of LMI Mail Group)
SNDALERT(ALERTMSG,NOUSER) ; EP - LR*5.2*1031 addes NOUSER parameter
S XQAMSG=ALERTMSG
S XQA("G.LMI")=""
;
; If User not part of LMI Mail Group, send them e-mail also, but
; If-And-Only-If the NOUSER variable is null.
; S:$$NINLMI(DUZ) XQA(DUZ)=""
S:$G(NOUSER)=""&($$NINLMI(DUZ)) XQA(DUZ)="" ; IHS/MSC/MKK - LR*5.2*1031
;
S X=$$SETUP1^XQALERT
K XQA,XQAMSG
Q:X
;
NEW SUBSCRPT
S SUBSCRPT="BLRLINKU Alert^"_+$H_"^"_$J
S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package Alert."
S ^XTMP(SUBSCRPT,1)="Alert was not sent."
S ^XTMP(SUBSCRPT,2)=" Message that should have been sent follows:"
S ^XTMP(SUBSCRPT,3)=" "_ALERTMSG
S ^XTMP(SUBSCRPT,4)=" ALERT Error Message Follows:"
S ^XTMP(SUBSCRPT,5)=" "_XQALERR
Q
;
NINLMI(CHKDUZ) ; EP -- Check to see if DUZ is NOT part of LMI Mail Group
NEW MGRPIEN,XMDUZ
;
; Get IEN of LMI MaiL Group
D CHKGROUP^XMBGRP("LMI",.MGRPIEN) ; VA DBIA 1146
Q:+(MGRPIEN)<1 1 ; If no Mail Group, return TRUE
;
; XMDUZ = DUZ of the user
; Y = IEN of the mail group
S XMDUZ=DUZ
S Y=MGRPIEN
D CHK^XMA21 ; VA DBIA 10067
;
Q $S($T=1:0,1:1)
;
; Send MailMan E-mail to LMI group AND User (if User is not a member of LMI Mail Group)
SENDMAIL(MAILMSG,MAILARRY,FROMWHOM,NOUSER) ; EP
NEW DIFROM
;
K XMY
S XMY("G.LMI")=""
;
; If User not part of LMI Mail Group, send them e-mail also, but
; If-And-Only-If the NOUSER variable is null.
S:$G(NOUSER)=""&($$NINLMI(DUZ)) XMY(DUZ)=""
;
S LRBLNOW=$E($$NOW^XLFDT,1,12)
;
S XMSUB=MAILMSG
S XMTEXT="MAILARRY("
S XMDUZ=FROMWHOM
S XMZ="NOT OKAY"
D ^XMD
;
I $G(XMMG)'=""!(XMZ="NOT OKAY") D
. NEW SUBSCRPT,ARRAY
. S SUBSCRPT="MailMan Message Failure^"_+$H_"^"_$J
. ; S ^XTEMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."
. ; S ^XTEMP(SUBSCRPT,1)="MailMan Message was not sent."
. ; S ^XTEMP(SUBSCRPT,2)=" Message that should have been sent follows:"
. ; S ARRAY=0
. ; F S ARRAY=$O(MAILARRY(ARRAY)) Q:ARRAY<1 D
.. ; S ^XTEMP(SUBSCRPT,(ARRAY+3))=" "_$G(MAILARRY(ARRAY))
. ;
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Use ^XTMP not ^XTEMP, per SAC
. S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."
. S ^XTMP(SUBSCRPT,1)="MailMan Message was not sent."
. S ^XTMP(SUBSCRPT,2)=" Message that should have been sent follows:"
. S ARRAY=0
. F S ARRAY=$O(MAILARRY(ARRAY)) Q:ARRAY<1 D
.. S ^XTMP(SUBSCRPT,(ARRAY+2))=" "_$G(MAILARRY(ARRAY))
. ; ----- END IHS/MSC/MKK - LR*5.2*1039
;
K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y ; Cleanup
Q
;
; ----- END IHS/OIT/MKK -- LR*5.2*1030
;
; ----- BEGIN IHS/MSC/MKK -- LR*5.2*1031
TESTMAIL ; EP
NEW DIFROM,STR
;
S STR(1)="SINGLE LINE OF TEXT"
;
K XMY
S XMY("G.LMI")=""
S XMSUB="TESTING MAILMAN"
S XMTEXT="STR("
S XMDUZ=DUZ
S XMZ="NOT OKAY"
D ^XMD
;
W "XMZ:",XMZ,!
W "XMMG:",$G(XMMG),!
;
K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y ; Cleanup
Q
; ----- END IHS/MSC/MKK -- LR*5.2*1031
BLRUTIL3 ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 04-Apr-2016 14:28 ; MKK
+1 ;;5.2;IHS LABORATORY;**1025,1027,1030,1031,1033,1039**;NOV 01, 1997;Build 38
+2 ;
+3 QUIT
+4 ;
+5 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025
GETACCCP(LRAS,LRAA,LRAD,LRAN) ; EP -- Take Accession # & break apart
+1 ; Parse and process user input. Cloned from LRWU4.
+2 NEW LRIDIV,LRQUIT,LRX,X1,X2,X3
+3 SET LRX=LRAS
+4 ;
+5 SET (LRAA,LRAD,LRAN)=""
+6 ;
+7 SET (X1,X2,X3)=""
SET X1=$PIECE(LRX," ",1)
SET X2=$PIECE(LRX," ",2)
SET X3=$PIECE(LRX," ",3)
+8 IF X3=""&(+X2=X2)
SET X3=X2
SET X2=""
+9 IF X1'?1A.AN
QUIT 0
+10 ;
+11 SET LRAA=$ORDER(^LRO(68,"B",X1,0))
+12 IF LRAA<1
QUIT 0
+13 ;
+14 ; S %=$P(^LRO(68,LRAA,0),U,14) ; Don't bother with Security Check
+15 ; I $L(%),'$D(^XUSEC(%,DUZ)) Q 0 ; Don't bother with Security Check
+16 ;
+17 SET LRX=$GET(^LRO(68,LRAA,0))
SET LRIDIV=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")
+18 ;
+19 ; Only accession area identifier, no date or number
+20 IF X2=""
IF X3=""
Begin DoDot:1
+21 NEW %DT
+22 SET %DT="AP"
SET %DT("A")=" Accession Date: "
SET %DT("B")="TODAY"
+23 ; D DATE^LRWU
+24 ; D DATE
+25 IF $DATA(DUOUT)
QUIT
+26 IF Y<1
QUIT
+27 SET LRAD=Y
End DoDot:1
+28 ;
+29 ; Convert middle value to FileMan date
+30 ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
+31 ; number as middle part of accession then convert to appropriate date.
+32 IF +$GET(LRAD)<1
Begin DoDot:1
+33 NEW %DT
+34 IF X2=""
SET X2=DT
+35 IF X2?4N
Begin DoDot:2
+36 SET X2=$EXTRACT(DT,1,3)_X2
+37 IF X2>DT
SET X2=X2-10000
End DoDot:2
+38 SET %DT="P"
SET X=X2
+39 DO ^%DT
+40 IF Y>0
SET LRAD=Y
QUIT
End DoDot:1
+41 IF +$GET(LRAD)<1
QUIT 0
+42 ;
+43 ; Convert date entered to apropriate date for accession area transform
+44 SET X=$PIECE(^LRO(68,LRAA,0),U,3)
+45 SET LRAD=$SELECT("D"[X:LRAD,X="Y":$EXTRACT(LRAD,1,3)_"0000","M"[X:$EXTRACT(LRAD,1,5)_"00","Q"[X:$EXTRACT(LRAD,1,3)_"0000"+(($EXTRACT(LRAD,4,5)-1)\3*300+100),1:LRAD)
+46 ; W:X3>0 " ",+X3
+47 ;
+48 IF X3=""
IF $DATA(LRACC)
Begin DoDot:1
+49 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+50 SET DIR(0)="NO^1:999999"
SET DIR("A")=" Number part of Accession"
+51 DO ^DIR
+52 IF Y=""!$DATA(DIRUT)
QUIT
+53 SET X3=Y
End DoDot:1
+54 ;
+55 IF X3=""
IF $DATA(LRACC)
QUIT 0
+56 SET LRAN=+X3
+57 QUIT 1
+58 ;
DATE ; EP
+1 KILL DTOUT,DUOUT
SET LREND=0
+2 ; W !,"DATE",!!,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B"),1:"TODAY"),"//" R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 I $D(DUOUT)!($D(DTOUT)) S LREND=1,Y=-1 Q
+3 IF X=""
SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"T")
IF $DATA(%DT)[0
SET %DT="E"
IF %DT["A"
SET %DT=$PIECE(%DT,"A",1)_$PIECE(%DT,"A",2)
IF %DT'["E"
SET %DT="E"_%DT
DO ^%DT
IF X="?"!(Y<1)
GOTO DATE
+4 KILL %DT
+5 QUIT
+6 ;
D2HBOLD(STR) ; EP - Write string DOUBLE HEIGHT & BOLDED
+1 WRITE !
+2 WRITE *27,"#3",*27,"[1m",STR,!
+3 WRITE *27,"#4",*27,"[1m",STR,!
+4 ; Turn OFF all attributes
WRITE *27,"[0m",!
+5 QUIT
+6 ;
BOLDUNDR(STR) ; EP -- Write string BOLDED & UNDERLINED
+1 WRITE *27,"[1;4m",STR,*27,"[0m"
+2 QUIT
+3 ;
REVIDEO(STR) ; EP -- Write string in Reverse Video & BOLDED
+1 WRITE *27,"[1;7m",STR,*27,"[0m"
+2 QUIT
+3 ; ----- END IHS/OIT/MKK LR*5.2*1025
+4 ;
+5 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1027
ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.
+1 NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB
+2 NEW REVSTS
+3 ;
+4 ; If E-SIG not turned on, Quit
+5 IF '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$GET(DUZ(2)))
QUIT
+6 ;
+7 ; LRDOC = Ordering Provider
SET DOCIEN=$ORDER(^VA(200,"B",LRDOC,""))
+8 ;
+9 ; If no IEN, Quit. Usually happens when LRDOC="Unknown"
+10 IF $GET(DOCIEN)=""
QUIT
+11 ;
+12 IF '($DATA(^BLRALAB(9009027.1,DOCIEN,0))#2)
WRITE ?56,"NOT E-SIG PARTICIPATING"
QUIT
+13 IF $PIECE(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A"
WRITE ?53,"INACTIVE E-SIG PARTICIPANT"
QUIT
+14 ;
+15 ;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.
+16 IF $GET(LRSS)=""
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+17 ;
+18 ; E-SIG string Data
SET ESIGDSTR=$GET(^LR(LRDFN,LRSS,LRIDT,9009027))
+19 ;
+20 ; NO Signing Physician
IF $PIECE(ESIGDSTR,U,2)=""
QUIT
+21 ; NOT Active
IF $PIECE(^BLRALAB(9009027.1,$PIECE(ESIGDSTR,U,2),0),U,7)'="A"
QUIT
+22 ;
+23 ; REVIEW status Data Values
+24 SET REVIEWDV=$$UP^XLFSTR($PIECE($GET(^DD(63.04,.9009025,0)),U,3))
+25 SET REVSTS=$PIECE($PIECE(REVIEWDV,$PIECE(ESIGDSTR,U)_":",2),";")
+26 ;
+27 ; Make sure E-SIG STATUS is flush right
+28 SET TAB=IOM-(16+$LENGTH(REVSTS))
+29 WRITE ?TAB,"E-SIG STATUS: ",REVSTS
+30 ;
+31 ; NO Signed Date
IF '$PIECE(ESIGDSTR,U,5)
QUIT
+32 ;
+33 ; NOT Reviewed
IF REVSTS["NOT REV"
QUIT
+34 ;
+35 WRITE !?5,"SIGNING PHYSICIAN: "
+36 WRITE $PIECE($GET(^VA(200,$PIECE(ESIGDSTR,U,2),0)),U)
+37 WRITE !?5,"DATE/TIME RESULT SIGNED: "
+38 WRITE $TRANSLATE($$FMTE^XLFDT($PIECE(ESIGDSTR,U,5),"2MZ"),"@"," ")
+39 QUIT
+40 ;
BLINKER(STR) ; EP -- Write string in BOLDED, UNDERLINED, & BLINKING
+1 WRITE *27,"[1;4;5m",STR,*27,"[0m"
+2 QUIT
+3 ;
+4 ; Cloned from LR7OSAP1. Wrap Text in array to ^TMP global
WRAP(ROOT,FMT) ; EP - Wrap text
+1 IF '$LENGTH($GET(ROOT))
QUIT ""
+2 NEW CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X
+3 IF '$GET(FMT)
SET FMT=79
+4 SET LRINDX=0
SET LRI=0
SET GCNT=0
+5 KILL ^TMP("BLRUTIL3",$JOB)
+6 FOR
SET LRI=$ORDER(@ROOT@(LRI))
IF LRI'>0
QUIT
Begin DoDot:1
+7 SET X=$SELECT($LENGTH($GET(@ROOT@(LRI))):@ROOT@(LRI),$LENGTH($GET(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:"")
SET LRINDX=LRINDX+1
+8 SET X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)
End DoDot:1
+9 SET LRI=0
+10 FOR
SET LRI=$ORDER(LRTX(LRI))
IF 'LRI
QUIT
DO LN^LR7OSAP
SET ^TMP("BLRUTIL3",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))
+11 QUIT
+12 ;
+13 ;
ALERT ; EP
+1 WRITE !!
+2 WRITE "Patient Name:",$PIECE(XQADATA,"^"),!
+3 WRITE " UID:",$PIECE(XQADATA,"^",2),!
+4 WRITE " TEST:",$PIECE(XQADATA,"^",3),!!
+5 QUIT
+6 ; ----- END IHS/OIT/MKK LR*5.2*1027
+7 ;
+8 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
REVBLINK(STR) ; EP - Print string in Bold, Blinking, Reverse Video
+1 WRITE *27,"[1;7;5m",STR,*27,"[0m"
+2 QUIT
+3 ;
+4 ; Moved PCC Bulletin code to here in order to standardize messages
+5 ; BLRBUL=1 SENDS BLRTXLOG BULLETIN
+6 ; BLRBUL=2 SENDS BLRTXLOGERR BULLETIN
+7 ; BLRBUL=3 SENDS BLRTXLOG AND BLRTXLOGERR BULLETIN
BULTNS ; EP - Send PCC Bulletin
+1 ; If Lab Deleted Test, don't send message.
IF BLRPCC["Lab deleted test"
QUIT
+2 ;
+3 IF "13"[BLRBUL
DO BULTX("BLRTXLOG")
IF BLRBUL=1
QUIT
+4 DO BULTX("BLRTXLOGERR")
+5 QUIT
+6 ;
BULTX(BULLETIN) ; EP - SEND BULLETIN IF PCC ERROR IN FILING
+1 ; Initialize array
KILL XMB
+2 ; Initialize variable
SET Y=""
+3 ;
+4 ; If BLRTXLOG number exists, use ^BLRTXLOG database
+5 IF +$GET(BLRLOGDA)>0
DO BULTXSET
+6 ;
+7 ; If BLRTXLOG number DOES NOT exist, use variables
+8 IF +$GET(BLRLOGDA)<1
DO BLTXNSET
+9 ;
+10 ; BLR Transaction Log Number
SET XMB(7)=$GET(BLRLOGDA)
+11 ;
+12 ; Error Message
SET XMB(8)=BLRPCC
+13 ;
+14 ; Bulletin to use
SET XMB=BULLETIN
+15 ;
+16 ; Send the Bulletin
+17 ; S BLRDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=BLRDUZ
+18 SET XMDUZ="Lab to PCC Link Processor"
+19 DO ^XMB
+20 ;
+21 ; Clean up
+22 KILL XMB
+23 QUIT
+24 ;
+25 ; Set bulletin parameters from ^BLRTXLOG global
BULTXSET ; EP
+1 NEW COLLDT,LABTIEN,PTPTR
+2 ;
+3 ; Patient Pointer
SET PTPTR=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",4)
+4 ;
+5 ; Patient Name
SET XMB(1)=$PIECE($GET(^DPT(PTPTR,0)),"^",1)
+6 ; LRDFN
SET XMB(2)=$GET(^DPT(PTPTR,"LR"))
+7 ;
+8 ; Date of Visit -- Collection Date
+9 SET COLLDT=$PIECE($GET(^BLRTXLOG(BLRLOGDA,12)),"^",1)
+10 SET XMB(3)=$$FMTE^XLFDT(COLLDT,"1D")
+11 ;
+12 ; Order Number
SET XMB(4)=$PIECE($GET(^BLRTXLOG(BLRLOGDA,11)),"^",3)
+13 ; Accession Number
SET XMB(5)=$PIECE($GET(^BLRTXLOG(BLRLOGDA,12)),"^",2)
+14 ;
+15 SET LABTIEN=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",6)
+16 ; Lab Test
SET XMB(6)=$PIECE($GET(^LAB(60,LABTIEN,0)),"^",1)
+17 ;
+18 QUIT
+19 ;
+20 ; Set bulletin parameters from variables
BLTXNSET ; EP
+1 NEW PTPTR
+2 ;
+3 ; Patient Pointer
SET PTPTR=+$GET(APCDALVR("APCDPAT"))
+4 ;
+5 ; Patient Name
SET XMB(1)=$PIECE($GET(^DPT(PTPTR,0)),"^",1)
+6 ; LRDFN
SET XMB(2)=$GET(^DPT(PTPTR,"LR"))
+7 ;
+8 ; Visit/Collection Date
+9 SET XMB(3)=$$FMTE^XLFDT($GET(APCDALVR("APCDDATE")),"1D")
+10 ;
+11 ; Order Number
SET XMB(4)=$GET(BLRORD)
+12 ; Accession Number
SET XMB(5)=$GET(BLRACCN)
+13 ; Test Description
SET XMB(6)=$PIECE($GET(^LAB(60,+$GET(BLRTEST),0)),"^",1)
+14 ;
+15 QUIT
+16 ;
+17 ; Get Reference Range for a Test for File 63
+18 ; Used by MEAG Delta Check
GETREFR(TESTNAME) ; EP
+1 NEW IEN,MESSAGE,REFL,REFH,SPEC,TARGET,UNITS
+2 ;
+3 ; Get Internal Entry Number of Test
+4 DO FIND^DIC(60,,,,TESTNAME,,,,,"TARGET","MESSAGE")
+5 SET IEN=+$GET(TARGET("DILIST",2,1))
+6 IF IEN<1
QUIT "!!!!!!!!"
+7 ;
+8 ; First Site/Spec
SET SPEC=+$ORDER(^LAB(60,IEN,1,0))
+9 IF SPEC<1
QUIT "!!!!!!!!"
+10 ;
+11 SET REFL=$$GET1^DIQ(60.01,SPEC_","_IEN_",",1,"I")
+12 SET REFH=$$GET1^DIQ(60.01,SPEC_","_IEN_",",2,"I")
+13 SET UNITS=$$GET1^DIQ(60.01,SPEC_","_IEN_",",6,"I")
+14 ;
+15 ; If UNITS is a pointer to the IHS UCUM file, get units text
+16 IF +$GET(UNITS)>0
SET UNITS=$PIECE($GET(^BLRUCUM(UNITS,0)),"^")
+17 ;
+18 QUIT SPEC_"!"_REFL_"!"_REFH_"!!!!"_UNITS_"!!"
+19 ;
INSTLRPT ; EP -- Report of ^BLRINSTL global
+1 NEW CP,CNT,WHO,WHEN
+2 NEW HEADER,PG,LINES,MAXLINES,QFLG,HD1
+3 ;
+4 DO INSTLRPI
+5 ;
+6 FOR
SET CP=$ORDER(^BLRINSTL("LAB PATCH",CP))
IF CP<1!(QFLG="Q")
QUIT
Begin DoDot:1
+7 FOR
SET CNT=$ORDER(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
IF CNT<1!(QFLG="Q")
QUIT
Begin DoDot:2
+8 DO INSTLRPL
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
INSTLRPI ; EP -- Initialize variables
+1 NEW DTRANGE,FIRST,FIRSTDT,FRSTPTCH,LAST,LASTPTCH
+2 SET HEADER(1)="IHS LAB Patches Report"
+3 ;
+4 SET FRSTPTCH=$ORDER(^BLRINSTL("LAB PATCH",0))
+5 SET FIRST=$ORDER(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))
+6 SET FIRSTDT=$PIECE($GET(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")
+7 ;
+8 SET LASTPTCH=$ORDER(^BLRINSTL("LAB PATCH","A"),-1)
+9 SET LAST=$ORDER(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)
+10 SET LASTDT=$PIECE($GET(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")
+11 ;
+12 SET HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT
+13 SET HEADER(3)=" "
+14 SET $EXTRACT(HEADER(4),5)="Patch"
+15 SET $EXTRACT(HEADER(4),15)="Who"
+16 SET $EXTRACT(HEADER(4),45)="When"
+17 ;
+18 SET MAXLINES=22
SET LINES=MAXLINES+10
SET PG=0
SET (HD1,QFLG)="NO"
+19 SET (CP,CNT)=0
+20 QUIT
+21 ;
INSTLRPL ; EP -- Line of Data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 WRITE ?4,CP
+4 WRITE ?14,$GET(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))
+5 WRITE ?44,$TRANSLATE($PIECE($GET(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")
+6 WRITE !
+7 SET LINES=LINES+1
+8 QUIT
+9 ;
MAKE132 ; EP - Force Screen to 132 Characters
+1 WRITE "Setting display to 132 column mode",!
+2 WRITE $CHAR(27)_"[?3h",!
+3 WRITE "132 column mode active.",!
+4 WRITE $TRANSLATE($JUSTIFY("",132)," ","*"),!
+5 WRITE !
+6 SET IOM=132
+7 QUIT
+8 ;
MAKE80 ; EP - Force Screen to 80 Characters
+1 WRITE "Setting display to 80 column mode",!
+2 WRITE $CHAR(27)_"[?3l",!
+3 WRITE "80 column mode active.",!
+4 WRITE $TRANSLATE($JUSTIFY("",80)," ","*"),!
+5 WRITE !
+6 SET IOM=80
+7 QUIT
+8 ;
+9 ; MAILALMI(MESSAGE,MSGARRAY,FROMWHOM) ; EP - send e-MAIL and an Alert to members of the LMI Mail Group
MAILALMI(MESSAGE,MSGARRAY,FROMWHOM,NOUSER) ; EP - IHS/MSC/MKK - LR*5.2*1031 adds the NOUSER parameter
+1 NEW MAILARRY
+2 ;
+3 ; Alert just sends MESSAGE string
+4 ; D SNDALERT(MESSAGE)
+5 ; IHS/MSC/MKK - LR*5.2*1031
DO SNDALERT(MESSAGE,$GET(NOUSER))
+6 ;
+7 ; Setup variables for sending MailMan e-mail
+8 IF $LENGTH($GET(MSGARRAY(1)))
MERGE MAILARRY=MSGARRAY
+9 ;
+10 ; If MSGARRAY null, create generic array
IF $LENGTH($GET(MSGARRAY(1)))<1
Begin DoDot:1
+11 SET MAILARRY(1)="The Subject of this email is the message:"
+12 SET MAILARRY(2)=" "_MESSAGE
End DoDot:1
+13 ;
+14 IF $GET(FROMWHOM)=""
SET FROMWHOM="RPMS Lab Package"
+15 ;
+16 ; D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM)
+17 ; IHS/MSC/MKK - LR*5.2*1031
DO SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM,$GET(NOUSER))
+18 ;
+19 IF $DATA(^XTMP("BLRUTIL3"))<1
Begin DoDot:1
+20 SET ^XTMP("BLRUTIL3",0)=$$HTFM^XLFDT(+$HOROLOG+30)_"^"_$$HTFM^XLFDT(+$HOROLOG)_"^MAILALMI Usage"
End DoDot:1
+21 ; M ^XTMP("BLRUTIL3","MAILALMI",$H,"DUZ")=DUZ
+22 ;
+23 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+24 NEW NOW
+25 SET NOW=$HOROLOG
+26 SET ^XTMP("BLRUTIL3","MAILALMI",NOW)=$$HTE^XLFDT(NOW,"5MZ")
+27 MERGE ^XTMP("BLRUTIL3","MAILALMI",NOW,"DUZ")=DUZ
+28 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+29 ;
+30 QUIT
+31 ;
+32 ; SNDALERT(ALERTMSG,NOUSER) ; EP - Send alert to LMI group AND User (if not member of LMI Mail Group)
SNDALERT(ALERTMSG,NOUSER) ; EP - LR*5.2*1031 addes NOUSER parameter
+1 SET XQAMSG=ALERTMSG
+2 SET XQA("G.LMI")=""
+3 ;
+4 ; If User not part of LMI Mail Group, send them e-mail also, but
+5 ; If-And-Only-If the NOUSER variable is null.
+6 ; S:$$NINLMI(DUZ) XQA(DUZ)=""
+7 ; IHS/MSC/MKK - LR*5.2*1031
IF $GET(NOUSER)=""&($$NINLMI(DUZ))
SET XQA(DUZ)=""
+8 ;
+9 SET X=$$SETUP1^XQALERT
+10 KILL XQA,XQAMSG
+11 IF X
QUIT
+12 ;
+13 NEW SUBSCRPT
+14 SET SUBSCRPT="BLRLINKU Alert^"_+$HOROLOG_"^"_$JOB
+15 SET ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package Alert."
+16 SET ^XTMP(SUBSCRPT,1)="Alert was not sent."
+17 SET ^XTMP(SUBSCRPT,2)=" Message that should have been sent follows:"
+18 SET ^XTMP(SUBSCRPT,3)=" "_ALERTMSG
+19 SET ^XTMP(SUBSCRPT,4)=" ALERT Error Message Follows:"
+20 SET ^XTMP(SUBSCRPT,5)=" "_XQALERR
+21 QUIT
+22 ;
NINLMI(CHKDUZ) ; EP -- Check to see if DUZ is NOT part of LMI Mail Group
+1 NEW MGRPIEN,XMDUZ
+2 ;
+3 ; Get IEN of LMI MaiL Group
+4 ; VA DBIA 1146
DO CHKGROUP^XMBGRP("LMI",.MGRPIEN)
+5 ; If no Mail Group, return TRUE
IF +(MGRPIEN)<1
QUIT 1
+6 ;
+7 ; XMDUZ = DUZ of the user
+8 ; Y = IEN of the mail group
+9 SET XMDUZ=DUZ
+10 SET Y=MGRPIEN
+11 ; VA DBIA 10067
DO CHK^XMA21
+12 ;
+13 QUIT $SELECT($TEST=1:0,1:1)
+14 ;
+15 ; Send MailMan E-mail to LMI group AND User (if User is not a member of LMI Mail Group)
SENDMAIL(MAILMSG,MAILARRY,FROMWHOM,NOUSER) ; EP
+1 NEW DIFROM
+2 ;
+3 KILL XMY
+4 SET XMY("G.LMI")=""
+5 ;
+6 ; If User not part of LMI Mail Group, send them e-mail also, but
+7 ; If-And-Only-If the NOUSER variable is null.
+8 IF $GET(NOUSER)=""&($$NINLMI(DUZ))
SET XMY(DUZ)=""
+9 ;
+10 SET LRBLNOW=$EXTRACT($$NOW^XLFDT,1,12)
+11 ;
+12 SET XMSUB=MAILMSG
+13 SET XMTEXT="MAILARRY("
+14 SET XMDUZ=FROMWHOM
+15 SET XMZ="NOT OKAY"
+16 DO ^XMD
+17 ;
+18 IF $GET(XMMG)'=""!(XMZ="NOT OKAY")
Begin DoDot:1
+19 NEW SUBSCRPT,ARRAY
+20 SET SUBSCRPT="MailMan Message Failure^"_+$HOROLOG_"^"_$JOB
+21 ; S ^XTEMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."
+22 ; S ^XTEMP(SUBSCRPT,1)="MailMan Message was not sent."
+23 ; S ^XTEMP(SUBSCRPT,2)=" Message that should have been sent follows:"
+24 ; S ARRAY=0
+25 ; F S ARRAY=$O(MAILARRY(ARRAY)) Q:ARRAY<1 D
+26 ; S ^XTEMP(SUBSCRPT,(ARRAY+3))=" "_$G(MAILARRY(ARRAY))
+27 ;
+28 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Use ^XTMP not ^XTEMP, per SAC
+29 SET ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."
+30 SET ^XTMP(SUBSCRPT,1)="MailMan Message was not sent."
+31 SET ^XTMP(SUBSCRPT,2)=" Message that should have been sent follows:"
+32 SET ARRAY=0
+33 FOR
SET ARRAY=$ORDER(MAILARRY(ARRAY))
IF ARRAY<1
QUIT
Begin DoDot:2
+34 SET ^XTMP(SUBSCRPT,(ARRAY+2))=" "_$GET(MAILARRY(ARRAY))
End DoDot:2
+35 ; ----- END IHS/MSC/MKK - LR*5.2*1039
End DoDot:1
+36 ;
+37 ; Cleanup
KILL X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
+38 QUIT
+39 ;
+40 ; ----- END IHS/OIT/MKK -- LR*5.2*1030
+41 ;
+42 ; ----- BEGIN IHS/MSC/MKK -- LR*5.2*1031
TESTMAIL ; EP
+1 NEW DIFROM,STR
+2 ;
+3 SET STR(1)="SINGLE LINE OF TEXT"
+4 ;
+5 KILL XMY
+6 SET XMY("G.LMI")=""
+7 SET XMSUB="TESTING MAILMAN"
+8 SET XMTEXT="STR("
+9 SET XMDUZ=DUZ
+10 SET XMZ="NOT OKAY"
+11 DO ^XMD
+12 ;
+13 WRITE "XMZ:",XMZ,!
+14 WRITE "XMMG:",$GET(XMMG),!
+15 ;
+16 ; Cleanup
KILL X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
+17 QUIT
+18 ; ----- END IHS/MSC/MKK -- LR*5.2*1031
