LR309 ;DALOI/CKA - LR*5.2*309 PATCH ENVIRONMENT CHECK ROUTINE ;June 10, 2008
;;5.2;LAB SERVICE;**309**;Sep 27, 1994;Build 23
;
; Use of ^XPDUTL is supported by Integration Agreement: 10141
; Use of ^XQALERT is supported by Integration Agreement: 10081
; Use of ^XLFSTR is supported by Integration Agreement: 10104
; Use of ^XLFDT is supported by Integration Agreement: 10103
; Use of ^DIK is supported by Integration Agreement: 10013
; Use of ^XUSER is supported by Integration Agreement: 2343
; Use of ^XMD is supported by Integration Agreement: 10070
;
EN ; Does not prevent loading of the transport global.
;
N XAQMSG,XQA,MSG
I '$G(XPDENV) D
.S XQAMSG="Transport global for patch "_$G(XPDNM,"Unknown patch")
.S XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($H)
.S XQA("G.LMI")=""
.D SETUP^XQALERT
.S MSG="Sending transport global loaded alert to mail group G.LMI"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
I $G(XPDENV) D
.S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
.S XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($H)
.S XQA("G.LMI")=""
.D SETUP^XQALERT
.S MSG="Sending install started alert to mail group G.LMI"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
D CHECK
I XPDENV S XPDDIQ("XPZ1","B")="YES"
D EXIT
Q
;
POST ; KIDS Post install for LR*5.2*309
N XQA,XQAMSG,LRRES,MSG,LRRMV
D BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",IOM))
D MATCH
I $O(^XTMP("LR309",0)) D
. D PRINT1
. D SEND
; Remove the data dictionary entry for the Description field(#20)in
; Cytopathology sub-file(#63.09) in LAB DATA file (#63).
D REMOVE
;If no data entries found in LAB DATA file #63 so it is okay to finish
I $O(^XTMP("LR309",""),-1)=0 D
. K MSG
. S MSG="No Data found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
. D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",IOM))
S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
S XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($H)
S XQA("G.LMI")=""
D SETUP^XQALERT
S MSG="Sending install completion alert to mail group G.LMI"
D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
Q
;
CHECK ; Perform environment check
I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D Q
.D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM))
.S XPDQUIT=2
I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D Q
.S MSG="Please log in to set local DUZ... variables"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
.S XPDQUIT=2
I '($$ACTIVE^XUSER(DUZ)) D Q
.S MSG="You are not a valid user on this system"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
.S XPDQUIT=2
Q
;
EXIT ;
I $G(XPDQUIT) D
.D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",IOM))
I '$G(XPDQUIT) D
.D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",IOM))
Q
;
MATCH ;
N LRDFN,LRI,XDATA1,LRMATFND,LREDATE,MSG,X,X1,X2,LRFNAM
N SEX,AGE,PNM,SSN,LRCNT,LRIDT,XDATA,XDATA2
K ^XTMP("LR309")
S X=$$FMADD^XLFDT($$NOW^XLFDT,180,0,0,0)
S ^XTMP("LR309",0)=X_"^"_$$NOW^XLFDT_"^LR309 DATA IN DESCRIPTION FIELD (#20)IN CYTOPATHOLOGY SUB-FILE(#63.09) IN LAB DATA FILE (#63) REPORT"
S MSG="Searching for data in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in LAB DATA file (#63)."
D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
S (LRDFN,LRMATFND,LRCNT)=0
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
.Q:'$D(^LR(LRDFN,"CY"))
.S LRIDT=0,(XDATA,XDATA2)=""
.K LRDPF,VADM,PNM,SSN,VA
.D PT^LRX
.K LRANS,LRERR
.S LRFNAM=$$GET1^DID(1,LRDPF,"","NAME","LRANS","LRERR")
.I $G(LRERR) S LRFNAM="UNKNOWN"
.F S LRIDT=$O(^LR(LRDFN,"CY",LRIDT)) Q:LRIDT<1 D
..I $D(^LR(LRDFN,"CY",LRIDT,"WP")) D
...S LREDATE=$$FMTE^XLFDT($P(^LR(LRDFN,"CY",LRIDT,"WP",0),"^",5),1)
...S LRMATFND=1
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"EDATE")=LREDATE
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")=LRFNAM
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")=PNM
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")=$S($G(SSN):SSN,1:"Unknown")
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE")=$S($G(AGE):AGE,1:"Unknown")
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")=$S(SEX="F":"FEMALE",SEX="M":"MALE",1:"Unknown")
...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN")=$P($G(^LR(LRDFN,"CY",LRIDT,0)),U,6)
...M ^XTMP("LR309",LRDFN,"CY",LRIDT,"WP")=^LR(LRDFN,"CY",LRIDT,"WP")
...K ^LR(LRDFN,"CY",LRIDT,"WP")
S MSG="Search finished"
D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
I $O(^XTMP("LR309",""),-1)>0 D
.S MSG="Data entries have been found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
.S MSG(1)=" "
.S MSG(2)="The data found is sent in a mail message to all users"
.S MSG(3)="who hold the security keys LRLIASON and LRAPSUPER. "
.S MSG(4)="The data will automatically be purged from the"
.S MSG(5)="^XTMP("_"""LR309"""_", global in 180 days. "
.S MSG(6)=" "
.S MSG(7)=" "
.S MSG(8)=" "
.S MSG(9)="Data deleted from DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in"
.S MSG(10)="LAB DATA file (#63)."
.D MES^XPDUTL(.MSG)
Q
REMOVE ;Removes the DD entry for field #20
N DIK,DA,MSG
S DIK="^DD(63.09,",DA=20,DA(1)=63.09 D ^DIK
Q
RECIP ; Find recipients with LRAPSUPER key and LRLIASON key.
S LRDUZ=0
F S LRDUZ=$O(^XUSEC("LRAPSUPER",LRDUZ)) Q:'LRDUZ S XMY(LRDUZ)=""
S LRDUZ=0
F S LRDUZ=$O(^XUSEC("LRLIASON",LRDUZ)) Q:'LRDUZ S XMY(LRDUZ)=""
K LRDUZ
Q
PRINT1 ; Actually print the report
K ^TMP($J)
N LRDATA,LRPAT,LRDATE,LRDFN,LRNAM,LRACC,PNM,LRSTATE,LRIDT
N LRLNCNT,LRI,LRPAGE,LRCURPNM,LRZTSK,LRLINE
N LRPDF,VADM,SSN,SEX,VA
I '$D(^XTMP("LR309")) Q
S LRDFN=""
S LRI=0,LRIDT=1
S LRPAGE=0,LRLNCNT=0
D HEADER2
F S LRDFN=$O(^XTMP("LR309",LRDFN)) Q:LRDFN="" D
. S LRIDT=""
. K PNM,LRPDF,VADM,SSN,SEX,SSN,VA
. D PT^LRX
. F S LRIDT=$O(^XTMP("LR309",LRDFN,"CY",LRIDT)) Q:LRIDT="" D
. . S LRACC=$P(^LR(LRDFN,"CY",LRIDT,0),U,6)
. . I (LRI'=LRIDT) D
. . . D PTHDR
. . . S LRI=LRIDT ; Flag so we do not repeat the entire patient header each time.
. . D PRTDATA
. . F LRI=1:1:2 S LRDATA=" " D MSG
Q
;
PTHDR ; header for each new patient entry
N LRDATA
S LRDATA="Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")
S LRDATA=LRDATA_" ("_^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")_" FILE)" D MSG
S LRDATA=" GENDER: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")
S LRDATA=LRDATA_" SSN: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")
S LRDATA=LRDATA_" Accession Number: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN") D MSG
S LRDATA=" AGE : "_^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE") D MSG
S LRDATA=" " D MSG
S LRDATA="Data Found in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (63.09) in LAB" D MSG
S LRDATA="DATA file (#63): " D MSG
S LRDATA="==============================================================================" D MSG
Q
;
PRTDATA ;
N LRDATA,DIR,DIRUT,MSG
S LRLINE=0
F S LRLINE=$O(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE)) Q:LRLINE<1 D
. S LRDATA=$G(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE,0)) D MSG
. S LRDATA=" " D MSG
S LRDATA="-----------------------------------------------------------------------------" D MSG
S LRDATA=" " D MSG
Q
;
N LRDATA
S LRPAGE=LRPAGE+1
S LRDATA=" LR309 DATA REPORT Page: "_LRPAGE D MSG
S LRDATA=" " D MSG
I (LRI=LRIDT) D
. S LRDATA="Continuation of Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME") D MSG
. S LRDATA=" " D MSG
F LRI=1:1:2 S LRDATA=" " D MSG
Q
;
MSG S ^TMP($J,"LR309",LRLNCNT)=LRDATA S LRLNCNT=LRLNCNT+1
Q
SEND ;Send the message to users of the security keys LRLIASON and LRAPSUPER
N DIFROM,XMY,XMSUB,XMTEXT,XMDUN
D RECIP
S XMSUB="LR*5.2*309 DATA REPORT"
S XMTEXT="^TMP("_$J_",""LR309"","
S XMDUN="LR*5.2*309"
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR309 7838 printed Sep 23, 2025@19:39:21 Page 2
LR309 ;DALOI/CKA - LR*5.2*309 PATCH ENVIRONMENT CHECK ROUTINE ;June 10, 2008
+1 ;;5.2;LAB SERVICE;**309**;Sep 27, 1994;Build 23
+2 ;
+3 ; Use of ^XPDUTL is supported by Integration Agreement: 10141
+4 ; Use of ^XQALERT is supported by Integration Agreement: 10081
+5 ; Use of ^XLFSTR is supported by Integration Agreement: 10104
+6 ; Use of ^XLFDT is supported by Integration Agreement: 10103
+7 ; Use of ^DIK is supported by Integration Agreement: 10013
+8 ; Use of ^XUSER is supported by Integration Agreement: 2343
+9 ; Use of ^XMD is supported by Integration Agreement: 10070
+10 ;
EN ; Does not prevent loading of the transport global.
+1 ;
+2 NEW XAQMSG,XQA,MSG
+3 IF '$GET(XPDENV)
Begin DoDot:1
+4 SET XQAMSG="Transport global for patch "_$GET(XPDNM,"Unknown patch")
+5 SET XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($HOROLOG)
+6 SET XQA("G.LMI")=""
+7 DO SETUP^XQALERT
+8 SET MSG="Sending transport global loaded alert to mail group G.LMI"
+9 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
End DoDot:1
+10 IF $GET(XPDENV)
Begin DoDot:1
+11 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
+12 SET XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($HOROLOG)
+13 SET XQA("G.LMI")=""
+14 DO SETUP^XQALERT
+15 SET MSG="Sending install started alert to mail group G.LMI"
+16 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
End DoDot:1
+17 DO CHECK
+18 IF XPDENV
SET XPDDIQ("XPZ1","B")="YES"
+19 DO EXIT
+20 QUIT
+21 ;
POST ; KIDS Post install for LR*5.2*309
+1 NEW XQA,XQAMSG,LRRES,MSG,LRRMV
+2 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",IOM))
+3 DO MATCH
+4 IF $ORDER(^XTMP("LR309",0))
Begin DoDot:1
+5 DO PRINT1
+6 DO SEND
End DoDot:1
+7 ; Remove the data dictionary entry for the Description field(#20)in
+8 ; Cytopathology sub-file(#63.09) in LAB DATA file (#63).
+9 DO REMOVE
+10 ;If no data entries found in LAB DATA file #63 so it is okay to finish
+11 IF $ORDER(^XTMP("LR309",""),-1)=0
Begin DoDot:1
+12 KILL MSG
+13 SET MSG="No Data found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
+14 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
End DoDot:1
+15 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",IOM))
+16 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
+17 SET XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($HOROLOG)
+18 SET XQA("G.LMI")=""
+19 DO SETUP^XQALERT
+20 SET MSG="Sending install completion alert to mail group G.LMI"
+21 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
+22 QUIT
+23 ;
CHECK ; Perform environment check
+1 IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
Begin DoDot:1
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM))
+3 SET XPDQUIT=2
End DoDot:1
QUIT
+4 IF $SELECT('$GET(DUZ):1,$DATA(DUZ)[0:1,$DATA(DUZ(0))[0:1,1:0)
Begin DoDot:1
+5 SET MSG="Please log in to set local DUZ... variables"
+6 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
+7 SET XPDQUIT=2
End DoDot:1
QUIT
+8 IF '($$ACTIVE^XUSER(DUZ))
Begin DoDot:1
+9 SET MSG="You are not a valid user on this system"
+10 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
+11 SET XPDQUIT=2
End DoDot:1
QUIT
+12 QUIT
+13 ;
EXIT ;
+1 IF $GET(XPDQUIT)
Begin DoDot:1
+2 DO BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",IOM))
End DoDot:1
+3 IF '$GET(XPDQUIT)
Begin DoDot:1
+4 DO BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",IOM))
End DoDot:1
+5 QUIT
+6 ;
MATCH ;
+1 NEW LRDFN,LRI,XDATA1,LRMATFND,LREDATE,MSG,X,X1,X2,LRFNAM
+2 NEW SEX,AGE,PNM,SSN,LRCNT,LRIDT,XDATA,XDATA2
+3 KILL ^XTMP("LR309")
+4 SET X=$$FMADD^XLFDT($$NOW^XLFDT,180,0,0,0)
+5 SET ^XTMP("LR309",0)=X_"^"_$$NOW^XLFDT_"^LR309 DATA IN DESCRIPTION FIELD (#20)IN CYTOPATHOLOGY SUB-FILE(#63.09) IN LAB DATA FILE (#63) REPORT"
+6 SET MSG="Searching for data in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in LAB DATA file (#63)."
+7 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
+8 SET (LRDFN,LRMATFND,LRCNT)=0
+9 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+10 if '$DATA(^LR(LRDFN,"CY"))
QUIT
+11 SET LRIDT=0
SET (XDATA,XDATA2)=""
+12 KILL LRDPF,VADM,PNM,SSN,VA
+13 DO PT^LRX
+14 KILL LRANS,LRERR
+15 SET LRFNAM=$$GET1^DID(1,LRDPF,"","NAME","LRANS","LRERR")
+16 IF $GET(LRERR)
SET LRFNAM="UNKNOWN"
+17 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CY",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+18 IF $DATA(^LR(LRDFN,"CY",LRIDT,"WP"))
Begin DoDot:3
+19 SET LREDATE=$$FMTE^XLFDT($PIECE(^LR(LRDFN,"CY",LRIDT,"WP",0),"^",5),1)
+20 SET LRMATFND=1
+21 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"EDATE")=LREDATE
+22 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")=LRFNAM
+23 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")=PNM
+24 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")=$SELECT($GET(SSN):SSN,1:"Unknown")
+25 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE")=$SELECT($GET(AGE):AGE,1:"Unknown")
+26 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")=$SELECT(SEX="F":"FEMALE",SEX="M":"MALE",1:"Unknown")
+27 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN")=$PIECE($GET(^LR(LRDFN,"CY",LRIDT,0)),U,6)
+28 MERGE ^XTMP("LR309",LRDFN,"CY",LRIDT,"WP")=^LR(LRDFN,"CY",LRIDT,"WP")
+29 KILL ^LR(LRDFN,"CY",LRIDT,"WP")
End DoDot:3
End DoDot:2
End DoDot:1
+30 SET MSG="Search finished"
+31 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
+32 IF $ORDER(^XTMP("LR309",""),-1)>0
Begin DoDot:1
+33 SET MSG="Data entries have been found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
+34 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
KILL MSG
+35 SET MSG(1)=" "
+36 SET MSG(2)="The data found is sent in a mail message to all users"
+37 SET MSG(3)="who hold the security keys LRLIASON and LRAPSUPER. "
+38 SET MSG(4)="The data will automatically be purged from the"
+39 SET MSG(5)="^XTMP("_"""LR309"""_", global in 180 days. "
+40 SET MSG(6)=" "
+41 SET MSG(7)=" "
+42 SET MSG(8)=" "
+43 SET MSG(9)="Data deleted from DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in"
+44 SET MSG(10)="LAB DATA file (#63)."
+45 DO MES^XPDUTL(.MSG)
End DoDot:1
+46 QUIT
REMOVE ;Removes the DD entry for field #20
+1 NEW DIK,DA,MSG
+2 SET DIK="^DD(63.09,"
SET DA=20
SET DA(1)=63.09
DO ^DIK
+3 QUIT
RECIP ; Find recipients with LRAPSUPER key and LRLIASON key.
+1 SET LRDUZ=0
+2 FOR
SET LRDUZ=$ORDER(^XUSEC("LRAPSUPER",LRDUZ))
if 'LRDUZ
QUIT
SET XMY(LRDUZ)=""
+3 SET LRDUZ=0
+4 FOR
SET LRDUZ=$ORDER(^XUSEC("LRLIASON",LRDUZ))
if 'LRDUZ
QUIT
SET XMY(LRDUZ)=""
+5 KILL LRDUZ
+6 QUIT
PRINT1 ; Actually print the report
+1 KILL ^TMP($JOB)
+2 NEW LRDATA,LRPAT,LRDATE,LRDFN,LRNAM,LRACC,PNM,LRSTATE,LRIDT
+3 NEW LRLNCNT,LRI,LRPAGE,LRCURPNM,LRZTSK,LRLINE
+4 NEW LRPDF,VADM,SSN,SEX,VA
+5 IF '$DATA(^XTMP("LR309"))
QUIT
+6 SET LRDFN=""
+7 SET LRI=0
SET LRIDT=1
+8 SET LRPAGE=0
SET LRLNCNT=0
+9 DO HEADER2
+10 FOR
SET LRDFN=$ORDER(^XTMP("LR309",LRDFN))
if LRDFN=""
QUIT
Begin DoDot:1
+11 SET LRIDT=""
+12 KILL PNM,LRPDF,VADM,SSN,SEX,SSN,VA
+13 DO PT^LRX
+14 FOR
SET LRIDT=$ORDER(^XTMP("LR309",LRDFN,"CY",LRIDT))
if LRIDT=""
QUIT
Begin DoDot:2
+15 SET LRACC=$PIECE(^LR(LRDFN,"CY",LRIDT,0),U,6)
+16 IF (LRI'=LRIDT)
Begin DoDot:3
+17 DO PTHDR
+18 ; Flag so we do not repeat the entire patient header each time.
SET LRI=LRIDT
End DoDot:3
+19 DO PRTDATA
+20 FOR LRI=1:1:2
SET LRDATA=" "
DO MSG
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PTHDR ; header for each new patient entry
+1 NEW LRDATA
+2 SET LRDATA="Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")
+3 SET LRDATA=LRDATA_" ("_^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")_" FILE)"
DO MSG
+4 SET LRDATA=" GENDER: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")
+5 SET LRDATA=LRDATA_" SSN: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")
+6 SET LRDATA=LRDATA_" Accession Number: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN")
DO MSG
+7 SET LRDATA=" AGE : "_^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE")
DO MSG
+8 SET LRDATA=" "
DO MSG
+9 SET LRDATA="Data Found in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (63.09) in LAB"
DO MSG
+10 SET LRDATA="DATA file (#63): "
DO MSG
+11 SET LRDATA="=============================================================================="
DO MSG
+12 QUIT
+13 ;
PRTDATA ;
+1 NEW LRDATA,DIR,DIRUT,MSG
+2 SET LRLINE=0
+3 FOR
SET LRLINE=$ORDER(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE))
if LRLINE<1
QUIT
Begin DoDot:1
+4 SET LRDATA=$GET(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE,0))
DO MSG
+5 SET LRDATA=" "
DO MSG
End DoDot:1
+6 SET LRDATA="-----------------------------------------------------------------------------"
DO MSG
+7 SET LRDATA=" "
DO MSG
+8 QUIT
+9 ;
+1 NEW LRDATA
+2 SET LRPAGE=LRPAGE+1
+3 SET LRDATA=" LR309 DATA REPORT Page: "_LRPAGE
DO MSG
+4 SET LRDATA=" "
DO MSG
+5 IF (LRI=LRIDT)
Begin DoDot:1
+6 SET LRDATA="Continuation of Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")
DO MSG
+7 SET LRDATA=" "
DO MSG
End DoDot:1
+8 FOR LRI=1:1:2
SET LRDATA=" "
DO MSG
+9 QUIT
+10 ;
MSG SET ^TMP($JOB,"LR309",LRLNCNT)=LRDATA
SET LRLNCNT=LRLNCNT+1
+1 QUIT
SEND ;Send the message to users of the security keys LRLIASON and LRAPSUPER
+1 NEW DIFROM,XMY,XMSUB,XMTEXT,XMDUN
+2 DO RECIP
+3 SET XMSUB="LR*5.2*309 DATA REPORT"
+4 SET XMTEXT="^TMP("_$JOB_",""LR309"","
+5 SET XMDUN="LR*5.2*309"
+6 DO ^XMD
+7 QUIT
