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

LR309.m

Go to the documentation of this file. 
  1. LR309 ;VA/DALOI/CKA - LR*5.2*309 PATCH ENVIRONMENT CHECK ROUTINE ;June 10, 2008
  1.  ;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 309
  1.  ;
  1.  ; 
  1.  ; Use of ^XPDUTL is supported by Integration Agreement: 10141
  1.  ; Use of ^XQALERT is supported by Integration Agreement: 10081
  1.  ; Use of ^XLFSTR is supported by Integration Agreement: 10104
  1.  ; Use of ^XLFDT is supported by Integration Agreement: 10103
  1.  ; Use of ^DIK is supported by Integration Agreement: 10013
  1.  ; Use of ^XUSER is supported by Integration Agreement: 2343
  1.  ; Use of ^XMD is supported by Integration Agreement: 10070
  1.  ; 
  1. EN ; Does not prevent loading of the transport global.
  1.  ;
  1.  N XAQMSG,XQA,MSG
  1.  I '$G(XPDENV) D
  1.  .S XQAMSG="Transport global for patch "_$G(XPDNM,"Unknown patch")
  1.  .S XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($H)
  1.  .S XQA("G.LMI")=""
  1.  .; D SETUP^XQALERT
  1.  .S MSG="Sending transport global loaded alert to mail group G.LMI"
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
  1.  I $G(XPDENV) D
  1.  .S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
  1.  .S XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($H)
  1.  .S XQA("G.LMI")=""
  1.  .; D SETUP^XQALERT
  1.  .S MSG="Sending install started alert to mail group G.LMI"
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$G(IOM,80)))    ; IHS/MSC/MKK
  1.  D CHECK
  1.  I XPDENV S XPDDIQ("XPZ1","B")="YES"
  1.  D EXIT
  1.  Q
  1.  ;
  1. POST ; KIDS Post install for LR*5.2*309
  1.  N XQA,XQAMSG,LRRES,MSG,LRRMV
  1.  ; D BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",IOM))
  1.  ; 
  1.  D BMES^XPDUTL($$CJ^XLFSTR("*** Post install for "_$G(XPDNM,"Unknown patch")_" started ***",$G(IOM,80)))   ; IHS/MSC/MKK 
  1.  ; 
  1.  D MATCH
  1.  I $O(^XTMP("LR309",0)) D
  1.  . D PRINT1
  1.  . D SEND
  1.  ; Remove the data dictionary entry for the Description field(#20)in
  1.  ; Cytopathology sub-file(#63.09) in LAB DATA file (#63).
  1.  D REMOVE
  1.  ;If no data entries found in LAB DATA file #63 so it is okay to finish 
  1.  I $O(^XTMP("LR309",""),-1)=0 D
  1.  . K MSG
  1.  . S MSG="No Data found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
  1.  . ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  . D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG             ; IHS/MSC/MKK
  1.  ; D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",IOM))
  1.  D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",$G(IOM,80)))  ; IHS/MSC/MKK
  1.  S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
  1.  S XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($H)
  1.  S XQA("G.LMI")=""
  1.  ; D SETUP^XQALERT
  1.  S MSG="Sending install completion alert to mail group G.LMI"
  1.  ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
  1.  D BMES^XPDUTL($$CJ^XLFSTR("--- "_XQAMSG_" ---",$G(IOM,80)))    ; IHS/MSC/MKK
  1.  Q
  1.  ;
  1. CHECK ; Perform environment check
  1.  D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check for "_$G(XPDNM,"Unknown patch")_" ---",80))      ; IHS/MSC/MKK
  1.  ;
  1.  I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D  Q
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",IOM))
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",$G(IOM,80)))     ; IHS/MSC/MKK
  1.  .S XPDQUIT=2
  1.  I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D  Q
  1.  .S MSG="Please log in to set local DUZ... variables"
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  .D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG    ; IHS/MSC/MKK
  1.  .S XPDQUIT=2
  1.  I '($$ACTIVE^XUSER(DUZ)) D  Q
  1.  .S MSG="You are not a valid user on this system"
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  .D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG    ; IHS/MSC/MKK
  1.  .S XPDQUIT=2
  1.  Q
  1.  ;
  1. EXIT ;
  1.  I $G(XPDQUIT) D
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",IOM))
  1.  I '$G(XPDQUIT) D
  1.  .; D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",IOM))
  1.  ;
  1.  I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$G(XPDNM,"Unknown patch")_" FAILED ---",$G(IOM,80)))    ; IHS/MSC/MKK
  1.  I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check for "_$G(XPDNM,"Unknown patch")_" is Ok ---",$G(IOM,80)))    ; IHS/MSC/MKK
  1.  ;
  1.  Q
  1.  ;
  1. MATCH ;
  1.  N LRDFN,LRI,XDATA1,LRMATFND,LREDATE,MSG,X,X1,X2,LRFNAM
  1.  N SEX,AGE,PNM,SSN,LRCNT,LRIDT,XDATA,XDATA2
  1.  K ^XTMP("LR309")
  1.  S X=$$FMADD^XLFDT($$NOW^XLFDT,180,0,0,0)
  1.  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"
  1.  S MSG="Searching for data in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in LAB DATA file (#63)."
  1.  ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG     ; IHS/MSC/MKK
  1.  S (LRDFN,LRMATFND,LRCNT)=0
  1.  F  S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1  D
  1.  .Q:'$D(^LR(LRDFN,"CY"))
  1.  .S LRIDT=0,(XDATA,XDATA2)=""
  1.  .K LRDPF,VADM,PNM,SSN,VA
  1.  .D PT^LRX
  1.  .K LRANS,LRERR
  1.  .S LRFNAM=$$GET1^DID(1,LRDPF,"","NAME","LRANS","LRERR")
  1.  .I $G(LRERR) S LRFNAM="UNKNOWN"
  1.  .F  S LRIDT=$O(^LR(LRDFN,"CY",LRIDT)) Q:LRIDT<1  D
  1.  ..I $D(^LR(LRDFN,"CY",LRIDT,"WP")) D
  1.  ...S LREDATE=$$FMTE^XLFDT($P(^LR(LRDFN,"CY",LRIDT,"WP",0),"^",5),1)
  1.  ...S LRMATFND=1
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"EDATE")=LREDATE
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")=LRFNAM
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")=PNM
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")=$S($G(SSN):SSN,1:"Unknown")
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE")=$S($G(AGE):AGE,1:"Unknown")
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")=$S(SEX="F":"FEMALE",SEX="M":"MALE",1:"Unknown")
  1.  ...S ^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN")=$P($G(^LR(LRDFN,"CY",LRIDT,0)),U,6)
  1.  ...M ^XTMP("LR309",LRDFN,"CY",LRIDT,"WP")=^LR(LRDFN,"CY",LRIDT,"WP")
  1.  ...K ^LR(LRDFN,"CY",LRIDT,"WP")
  1.  S MSG="Search finished"
  1.  ; D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG     ; IHS/MSC/MKK
  1.  I $O(^XTMP("LR309",""),-1)>0 D
  1.  .S MSG="Data entries have been found in ^LR(D0,"_"""CY"""_",D1,"_"""WP"""_",0)"
  1.  .;D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) K MSG
  1.  .D BMES^XPDUTL($$CJ^XLFSTR(MSG,$G(IOM,80))) K MSG    ; IHS/MSC/MKK
  1.  .S MSG(1)=" "
  1.  .S MSG(2)="The data found is sent in a mail message to all users"
  1.  .S MSG(3)="who hold the security keys LRLIASON and LRAPSUPER. "
  1.  .S MSG(4)="The data will automatically be purged from the"
  1.  .S MSG(5)="^XTMP("_"""LR309"""_", global in 180 days. "
  1.  .S MSG(6)=" "
  1.  .S MSG(7)=" "
  1.  .S MSG(8)=" "
  1.  .S MSG(9)="Data deleted from DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (#63.09) in"
  1.  .S MSG(10)="LAB DATA file (#63)."
  1.  .D MES^XPDUTL(.MSG)
  1.  Q
  1. REMOVE ;Removes the DD entry for field #20
  1.  N DIK,DA,MSG
  1.  S DIK="^DD(63.09,",DA=20,DA(1)=63.09 D ^DIK
  1.  Q
  1. RECIP ; Find recipients with LRAPSUPER key and LRLIASON key.
  1.  S LRDUZ=0
  1.  F  S LRDUZ=$O(^XUSEC("LRAPSUPER",LRDUZ)) Q:'LRDUZ  S XMY(LRDUZ)=""
  1.  S LRDUZ=0
  1.  F  S LRDUZ=$O(^XUSEC("LRLIASON",LRDUZ)) Q:'LRDUZ  S XMY(LRDUZ)=""
  1.  K LRDUZ
  1.  Q
  1. PRINT1 ; Actually print the report
  1.  ; K ^TMP($J)
  1.  K ^TMP("LR309",$J)                                        ; IHS/MSC/MKK
  1.  N LRDATA,LRPAT,LRDATE,LRDFN,LRNAM,LRACC,PNM,LRSTATE,LRIDT
  1.  N LRLNCNT,LRI,LRPAGE,LRCURPNM,LRZTSK,LRLINE
  1.  N LRPDF,VADM,SSN,SEX,VA
  1.  I '$D(^XTMP("LR309")) Q
  1.  S LRDFN=""
  1.  S LRI=0,LRIDT=1
  1.  S LRPAGE=0,LRLNCNT=0
  1.  D HEADER2
  1.  F  S LRDFN=$O(^XTMP("LR309",LRDFN)) Q:LRDFN=""  D
  1.  . S LRIDT=""
  1.  . K PNM,LRPDF,VADM,SSN,SEX,SSN,VA
  1.  . D PT^LRX
  1.  . F  S LRIDT=$O(^XTMP("LR309",LRDFN,"CY",LRIDT)) Q:LRIDT=""  D
  1.  . . S LRACC=$P(^LR(LRDFN,"CY",LRIDT,0),U,6)
  1.  . . I (LRI'=LRIDT) D
  1.  . . . D PTHDR
  1.  . . . S LRI=LRIDT  ; Flag so we do not repeat the entire patient header each time.
  1.  . . D PRTDATA
  1.  . . F LRI=1:1:2 S LRDATA=" " D MSG
  1.  Q
  1.  ;
  1. PTHDR ; header for each new patient entry
  1.  N LRDATA
  1.  S LRDATA="Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME")
  1.  S LRDATA=LRDATA_" ("_^XTMP("LR309",LRDFN,"CY",LRIDT,"SRC")_" FILE)" D MSG
  1.  S LRDATA=" GENDER: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SEX")
  1.  S LRDATA=LRDATA_"    SSN: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"SSN")
  1.  S LRDATA=LRDATA_"    Accession Number: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"ACN") D MSG
  1.  S LRDATA=" AGE   : "_^XTMP("LR309",LRDFN,"CY",LRIDT,"AGE") D MSG
  1.  S LRDATA=" " D MSG
  1.  S LRDATA="Data Found in DESCRIPTION field (#20) in CYTOPATHOLOGY sub-file (63.09) in LAB" D MSG
  1.  S LRDATA="DATA file (#63): " D MSG
  1.  S LRDATA="==============================================================================" D MSG
  1.  Q
  1.  ;
  1. PRTDATA ;
  1.  N LRDATA,DIR,DIRUT,MSG
  1.  S LRLINE=0
  1.  F  S LRLINE=$O(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE)) Q:LRLINE<1  D
  1.  . S LRDATA=$G(^XTMP("LR309",LRDFN,"CY",LRIDT,"WP",LRLINE,0)) D MSG
  1.  . S LRDATA=" " D MSG
  1.  S LRDATA="-----------------------------------------------------------------------------" D MSG
  1.  S LRDATA=" " D MSG
  1.  Q
  1.  ;
  1. HEADER2 ; Prints header for all other pages
  1.  N LRDATA
  1.  S LRPAGE=LRPAGE+1
  1.  S LRDATA="                              LR309 DATA REPORT            Page: "_LRPAGE D MSG
  1.  S LRDATA=" " D MSG
  1.  I (LRI=LRIDT) D
  1.  . S LRDATA="Continuation of Patient: "_^XTMP("LR309",LRDFN,"CY",LRIDT,"NAME") D MSG
  1.  . S LRDATA=" " D MSG
  1.  F LRI=1:1:2 S LRDATA=" " D MSG
  1.  Q
  1.  ;
  1. MSG ; S ^TMP($J,"LR309",LRLNCNT)=LRDATA S LRLNCNT=LRLNCNT+1
  1.  S ^TMP("LR309",$J,LRLNCNT)=LRDATA S LRLNCNT=LRLNCNT+1  ; IHS/MSC/MKK
  1.  Q
  1. SEND ;Send the message to users of the security keys LRLIASON and LRAPSUPER
  1.  N DIFROM,XMY,XMSUB,XMTEXT,XMDUN
  1.  D RECIP
  1.  S XMSUB="LR*5.2*309 DATA REPORT"
  1.  ; S XMTEXT="^TMP("_$J_",""LR309"","
  1.  S XMTEXT="^TMP(""LR309"","_$J_","
  1.  S XMDUN="LR*5.2*309"
  1.  D ^XMD
  1.  Q