LR309 ;VA/DALOI/CKA - LR*5.2*309 PATCH ENVIRONMENT CHECK ROUTINE ;June 10, 2008
;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
;
;;VA LR Patche(s): 309
;
;
; 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 BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$G(IOM,80))) ; IHS/MSC/MKK
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 BMES^XPDUTL($$CJ^XLFSTR("*** Post install for "_$G(XPDNM,"Unknown patch")_" started ***",$G(IOM,80))) ; IHS/MSC/MKK
;
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(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
; D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",IOM))
D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",$G(IOM,80))) ; IHS/MSC/MKK
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))
D BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$G(IOM,80))) ; IHS/MSC/MKK
Q
;
CHECK ; Perform environment check
D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check for "_$G(XPDNM,"Unknown patch")_" ---",80)) ; IHS/MSC/MKK
;
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))
. D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",$G(IOM,80))) ; IHS/MSC/MKK
.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
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
.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
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
.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))
;
I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$G(XPDNM,"Unknown patch")_" FAILED ---",$G(IOM,80))) ; IHS/MSC/MKK
I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$G(XPDNM,"Unknown patch")_" is Ok ---",$G(IOM,80))) ; IHS/MSC/MKK
;
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
D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
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
D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
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
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG ; IHS/MSC/MKK
.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)
K ^TMP("LR309",$J) ; IHS/MSC/MKK
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
S ^TMP("LR309",$J,LRLNCNT)=LRDATA S LRLNCNT=LRLNCNT+1 ; IHS/MSC/MKK
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 XMTEXT="^TMP(""LR309"","_$J_","
S XMDUN="LR*5.2*309"
D ^XMD
Q
LR309 ;VA/DALOI/CKA - LR*5.2*309 PATCH ENVIRONMENT CHECK ROUTINE ;June 10, 2008
+1 ;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patche(s): 309
+4 ;
+5 ;
+6 ; Use of ^XPDUTL is supported by Integration Agreement: 10141
+7 ; Use of ^XQALERT is supported by Integration Agreement: 10081
+8 ; Use of ^XLFSTR is supported by Integration Agreement: 10104
+9 ; Use of ^XLFDT is supported by Integration Agreement: 10103
+10 ; Use of ^DIK is supported by Integration Agreement: 10013
+11 ; Use of ^XUSER is supported by Integration Agreement: 2343
+12 ; Use of ^XMD is supported by Integration Agreement: 10070
+13 ;
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 ; D SETUP^XQALERT
+8 SET MSG="Sending transport global loaded alert to mail group G.LMI"
+9 ; D 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 ; D SETUP^XQALERT
+15 SET MSG="Sending install started alert to mail group G.LMI"
+16 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
+17 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$GET(IOM,80)))
End DoDot:1
+18 DO CHECK
+19 IF XPDENV
SET XPDDIQ("XPZ1","B")="YES"
+20 DO EXIT
+21 QUIT
+22 ;
POST ; KIDS Post install for LR*5.2*309
+1 NEW XQA,XQAMSG,LRRES,MSG,LRRMV
+2 ; D BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",IOM))
+3 ;
+4 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install for "_$GET(XPDNM,"Unknown patch")_" started ***",$GET(IOM,80)))
+5 ;
+6 DO MATCH
+7 IF $ORDER(^XTMP("LR309",0))
Begin DoDot:1
+8 DO PRINT1
+9 DO SEND
End DoDot:1
+10 ; Remove the data dictionary entry for the Description field(#20)in
+11 ; Cytopathology sub-file(#63.09) in LAB DATA file (#63).
+12 DO REMOVE
+13 ;If no data entries found in LAB DATA file #63 so it is okay to finish
+14 IF $ORDER(^XTMP("LR309",""),-1)=0
Begin DoDot:1
+15 KILL MSG
+16 SET MSG="No Data found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
+17 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+18 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
End DoDot:1
+19 ; D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",IOM))
+20 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",$GET(IOM,80)))
+21 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
+22 SET XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($HOROLOG)
+23 SET XQA("G.LMI")=""
+24 ; D SETUP^XQALERT
+25 SET MSG="Sending install completion alert to mail group G.LMI"
+26 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
+27 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$GET(IOM,80)))
+28 QUIT
+29 ;
CHECK ; Perform environment check
+1 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check for "_$GET(XPDNM,"Unknown patch")_" ---",80))
+2 ;
+3 IF $SELECT('$GET(IOM):1,'$GET(IOSL):1,$GET(U)'="^":1,1:0)
Begin DoDot:1
+4 ; D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM))
+5 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",$GET(IOM,80)))
+6 SET XPDQUIT=2
End DoDot:1
QUIT
+7 IF $SELECT('$GET(DUZ):1,$DATA(DUZ)[0:1,$DATA(DUZ(0))[0:1,1:0)
Begin DoDot:1
+8 SET MSG="Please log in to set local DUZ... variables"
+9 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+10 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
+11 SET XPDQUIT=2
End DoDot:1
QUIT
+12 IF '($$ACTIVE^XUSER(DUZ))
Begin DoDot:1
+13 SET MSG="You are not a valid user on this system"
+14 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+15 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
+16 SET XPDQUIT=2
End DoDot:1
QUIT
+17 QUIT
+18 ;
EXIT ;
+1 IF $GET(XPDQUIT)
Begin DoDot:1
+2 ; D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",IOM))
End DoDot:1
+3 IF '$GET(XPDQUIT)
Begin DoDot:1
+4 ; D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",IOM))
End DoDot:1
+5 ;
+6 ; IHS/MSC/MKK
IF $GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$GET(XPDNM,"Unknown patch")_" FAILED ---",$GET(IOM,80)))
+7 ; IHS/MSC/MKK
IF '$GET(XPDQUIT)
DO BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$GET(XPDNM,"Unknown patch")_" is Ok ---",$GET(IOM,80)))
+8 ;
+9 QUIT
+10 ;
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 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+8 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
+9 SET (LRDFN,LRMATFND,LRCNT)=0
+10 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
Begin DoDot:1
+11 IF '$DATA(^LR(LRDFN,"CY"))
QUIT
+12 SET LRIDT=0
SET (XDATA,XDATA2)=""
+13 KILL LRDPF,VADM,PNM,SSN,VA
+14 DO PT^LRX
+15 KILL LRANS,LRERR
+16 SET LRFNAM=$$GET1^DID(1,LRDPF,"","NAME","LRANS","LRERR")
+17 IF $GET(LRERR)
SET LRFNAM="UNKNOWN"
+18 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CY",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:2
+19 IF $DATA(^LR(LRDFN,"CY",LRIDT,"WP"))
Begin DoDot:3
+20 SET LREDATE=$$FMTE^XLFDT($PIECE(^LR(LRDFN,"CY",LRIDT,"WP",0),"^",5),1)
+21 SET LRMATFND=1
+22 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"EDATE")=LREDATE
+23 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")=LRFNAM
+24 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")=PNM
+25 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")=$SELECT($GET(SSN):SSN,1:"Unknown")
+26 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE")=$SELECT($GET(AGE):AGE,1:"Unknown")
+27 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")=$SELECT(SEX="F":"FEMALE",SEX="M":"MALE",1:"Unknown")
+28 SET ^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN")=$PIECE($GET(^LR(LRDFN,"CY",LRIDT,0)),U,6)
+29 MERGE ^XTMP("LR309",LRDFN,"CY",LRIDT,"WP")=^LR(LRDFN,"CY",LRIDT,"WP")
+30 KILL ^LR(LRDFN,"CY",LRIDT,"WP")
End DoDot:3
End DoDot:2
End DoDot:1
+31 SET MSG="Search finished"
+32 ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+33 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
+34 IF $ORDER(^XTMP("LR309",""),-1)>0
Begin DoDot:1
+35 SET MSG="Data entries have been found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
+36 ;D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
+37 ; IHS/MSC/MKK
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,$GET(IOM,80)))
KILL MSG
+38 SET MSG(1)=" "
+39 SET MSG(2)="The data found is sent in a mail message to all users"
+40 SET MSG(3)="who hold the security keys LRLIASON and LRAPSUPER. "
+41 SET MSG(4)="The data will automatically be purged from the"
+42 SET MSG(5)="^XTMP("_"""LR309"""_", global in 180 days. "
+43 SET MSG(6)=" "
+44 SET MSG(7)=" "
+45 SET MSG(8)=" "
+46 SET MSG(9)="Data deleted from DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in"
+47 SET MSG(10)="LAB DATA file (#63)."
+48 DO MES^XPDUTL(.MSG)
End DoDot:1
+49 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 ; K ^TMP($J)
+2 ; IHS/MSC/MKK
KILL ^TMP("LR309",$JOB)
+3 NEW LRDATA,LRPAT,LRDATE,LRDFN,LRNAM,LRACC,PNM,LRSTATE,LRIDT
+4 NEW LRLNCNT,LRI,LRPAGE,LRCURPNM,LRZTSK,LRLINE
+5 NEW LRPDF,VADM,SSN,SEX,VA
+6 IF '$DATA(^XTMP("LR309"))
QUIT
+7 SET LRDFN=""
+8 SET LRI=0
SET LRIDT=1
+9 SET LRPAGE=0
SET LRLNCNT=0
+10 DO HEADER2
+11 FOR
SET LRDFN=$ORDER(^XTMP("LR309",LRDFN))
IF LRDFN=""
QUIT
Begin DoDot:1
+12 SET LRIDT=""
+13 KILL PNM,LRPDF,VADM,SSN,SEX,SSN,VA
+14 DO PT^LRX
+15 FOR
SET LRIDT=$ORDER(^XTMP("LR309",LRDFN,"CY",LRIDT))
IF LRIDT=""
QUIT
Begin DoDot:2
+16 SET LRACC=$PIECE(^LR(LRDFN,"CY",LRIDT,0),U,6)
+17 IF (LRI'=LRIDT)
Begin DoDot:3
+18 DO PTHDR
+19 ; Flag so we do not repeat the entire patient header each time.
SET LRI=LRIDT
End DoDot:3
+20 DO PRTDATA
+21 FOR LRI=1:1:2
SET LRDATA=" "
DO MSG
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
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 ; S ^TMP($J,"LR309",LRLNCNT)=LRDATA S LRLNCNT=LRLNCNT+1
+1 ; IHS/MSC/MKK
SET ^TMP("LR309",$JOB,LRLNCNT)=LRDATA
SET LRLNCNT=LRLNCNT+1
+2 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 ; S XMTEXT="^TMP("_$J_",""LR309"","
+5 SET XMTEXT="^TMP(""LR309"","_$JOB_","
+6 SET XMDUN="LR*5.2*309"
+7 DO ^XMD
+8 QUIT
