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

IBDY343.m

Go to the documentation of this file. 
  1. IBDY343 ;ALB/ESD - PRE AND POST INSTALL FOR PATCH IBD*3*43 ; AUG 1, 2000
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**43**;APR 24, 1997
  1.  ;
  1. PRE ;- Create EF block list report and clear workspace before install
  1.  D BLKLIST
  1.  D CLWKSP
  1.  Q
  1.  ;
  1.  ;
  1. POST ;- Add toolkit blocks
  1.  D TKBLKS
  1.  Q
  1.  ;
  1.  ;
  1. CLWKSP ;- Clear the AICS Import/Export Workspace (files in #358) before
  1.  ;- loading new toolkit blocks
  1.  ;
  1.  D MES^XPDUTL("")
  1.  D BMES^XPDUTL(">>> Clearing AICS Import/Export workspace...")
  1.  D DLTALL^IBDE2
  1.  D MES^XPDUTL(">>> ...completed.")
  1.  Q
  1.  ;
  1.  ;
  1. BLKLIST ;- List tool kit blocks, forms, div(s), and clinic(s) so that users can
  1.  ;- find and change them to the new EF blocks containing Enrollment 
  1.  ;- Priority
  1.  ;
  1.  N ARRYVAL,BLKIEN,BLKNAM,BLOCK,CLINIC,CNT,DIV,DIVNAM,FORMIEN,FORM,LINE,LINECNT,MULTI
  1.  K ^TMP("DILIST",$J),^TMP($J,"IBDCS"),^TMP($J,"IBDCN"),^TMP("IBD43",$J)
  1.  ;
  1.  ;- Display info msg to patch installer
  1.  D USERMSG
  1.  ;
  1.  ;- Var used in CLINIC^IBDF15A call for multiple divs; must be defined
  1.  S MULTI=0
  1.  S LINECNT=19
  1.  F LINE=1:1 S BLKNAM=$P($T(LIST+LINE),";;",2) Q:(BLKNAM="QUIT")  D
  1.  . D FIND^DIC(357.1,"",".01;.02","",BLKNAM)
  1.  . F CNT=0:0 S CNT=$O(^TMP("DILIST",$J,2,CNT)) Q:'CNT  D
  1.  .. S BLKIEN=+$G(^TMP("DILIST",$J,2,CNT))
  1.  .. ;
  1.  .. ;- Get block and what form it's on
  1.  .. S BLOCK=$P($G(^IBE(357.1,BLKIEN,0)),"^")
  1.  .. S FORMIEN=+$P($G(^IBE(357.1,BLKIEN,0)),"^",2)
  1.  .. S FORM=$P($G(^IBE(357,FORMIEN,0)),"^")
  1.  .. ;
  1.  .. ;- Don't list blocks on the Form tool kit
  1.  .. Q:FORMIEN<1!(FORM="")!(FORM="TOOL KIT")!(FORM="TOOLKIT BLOCKS")
  1.  .. ;
  1.  .. ;- Get list of clinics and division(s) using form
  1.  .. D CLINIC^IBDF15A(FORMIEN,FORM)
  1.  .. S (CLINIC,DIVNAM)="",DIV=0
  1.  .. F  S DIVNAM=$O(^TMP($J,"IBDCS",DIVNAM)) Q:DIVNAM=""  F  S DIV=$O(^TMP($J,"IBDCS",DIVNAM,DIV)) Q:'DIV  D
  1.  ... F  S CLINIC=$O(^TMP($J,"IBDCS",DIVNAM,DIV,FORM,FORMIEN,CLINIC)) Q:CLINIC=""  D WRITELST(.LINECNT)
  1.  ;
  1.  ;- Briefly explain rpt and list old and new EF blocks
  1.  D XMHDR
  1.  I '$D(^TMP("IBD43",$J,19)) S ^TMP("IBD43",$J,19)="          No AICS encounter form information found"
  1.  D XM
  1.  D MES^XPDUTL(">>> ...completed.")
  1.  K ^TMP("DILIST",$J),^TMP($J,"IBDCS"),^TMP($J,"IBDCN"),^TMP("IBD43",$J)
  1.  Q
  1.  ;
  1.  ;
  1. WRITELST(CNT) ;- Print block & form on 1st line, clinic & division on 2nd line
  1.  N LINE
  1.  S LINE=$$SETSTR^VALM1(" Block:  "_BLOCK,"",1,40),LINE=$$SETSTR^VALM1("      Form:  "_FORM,LINE,43,36)
  1.  D INCR(.CNT)
  1.  S LINE=$$SETSTR^VALM1("Clinic:  "_CLINIC,"",1,40),LINE=$$SETSTR^VALM1("  Division:  "_$E(DIVNAM,1,25),LINE,43,36)
  1.  D INCR(.CNT)
  1.  S LINE=$$SETSTR^VALM1(" ","",1,80)
  1.  D INCR(.CNT)
  1.  Q
  1.  ;
  1.  ;
  1. INCR(CNT) ;- Create output array
  1.  S ^TMP("IBD43",$J,CNT)=LINE
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1.  ;
  1. XM ;- Send mail message to patch installer
  1.  N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  S XMSUB="Patch IBD*3*43 Encounter Form Block Report"
  1.  S XMDUZ=.5
  1.  S XMY(DUZ)=""
  1.  S XMY(XMDUZ)=""
  1.  S XMTEXT="^TMP(""IBD43"",$J,"
  1.  D ^XMD
  1.  Q
  1.  ;
  1.  ;
  1. XMHDR ;- Report header
  1.  ;
  1.  S ^TMP("IBD43",$J,1)=" Patch IBD*3*43 contains a number of encounter form blocks which were"
  1.  S ^TMP("IBD43",$J,2)=" modified to include the Enrollment Priority. These new"
  1.  S ^TMP("IBD43",$J,3)=" encounter form blocks should replace the existing encounter form"
  1.  S ^TMP("IBD43",$J,4)=" blocks on all applicable encounter forms."
  1.  S ^TMP("IBD43",$J,5)=" "
  1.  S ^TMP("IBD43",$J,6)=" This report will assist the user in replacing these blocks by listing the"
  1.  S ^TMP("IBD43",$J,7)=" existing encounter form blocks, the encounter form(s) they are located on,"
  1.  S ^TMP("IBD43",$J,8)=" and all clinic(s), and division(s) using the encounter form."
  1.  S ^TMP("IBD43",$J,9)=" "
  1.  S ^TMP("IBD43",$J,10)="    Old block                        New block"
  1.  S ^TMP("IBD43",$J,11)="    =========                        ========="
  1.  S ^TMP("IBD43",$J,12)=" "
  1.  S ^TMP("IBD43",$J,13)="    PATIENT INFORMATION (V2.1)       PATIENT INFORMATION (V3.0)"
  1.  S ^TMP("IBD43",$J,14)="    BASIC DEMOGRAPHICS               BASIC DEMOGRAPHICS (V3.0)"
  1.  S ^TMP("IBD43",$J,15)="    BASIC DEMOGRAPHICS (MST)         BASIC DEMOGRAPHICS (V3.0)"
  1.  S ^TMP("IBD43",$J,16)=" "
  1.  Q
  1.  ;
  1.  ;
  1. USERMSG ;- Info message displayed during patch install
  1.  ;
  1.  D BMES^XPDUTL(">>> Creating encounter form block report to aid user in finding existing")
  1.  D MES^XPDUTL(">>> encounter form blocks and replacing them with blocks containing the")
  1.  D MES^XPDUTL(">>> Enrollment Priority.")
  1.  D BMES^XPDUTL(">>> This report will be sent as a mail message to the patch installer")
  1.  D MES^XPDUTL(">>> with the subject ""Patch IBD*3*43 Encounter Form Block Report"".")
  1.  Q
  1.  ;
  1.  ;
  1. TKBLKS ;- Add Enrollment Priority tool kit blocks to AICS Tool Kit
  1.  ;
  1.  N A,ARY,BLK,CNT,CNT1,CNTB,CNTF,EXCLUDE,FORM,FORMNM,NAME,IBDNM,IBDBLK,IBDX,IBTKBLK,NEWBLOCK,NEWFORM,NUM,ORD,SUMMARY,X,Y
  1.  ;
  1.  ;- Add all tool kit blocks
  1.  S FORMNM="TOOL KIT"
  1.  S (CNTB,CNTF)=0,NUM=1
  1.  D BMES^XPDUTL(">>> Adding Enrollment Priority Tool Kit blocks to the AICS Tool Kit...")
  1.  ;
  1.  ;- Display error msg and exit if Tool Kit not found
  1.  I '$O(^IBE(357,"B",FORMNM,0)) D TKERR Q
  1.  ;
  1.  ;- Get blocks from Imp/Exp EF Block file
  1.  S ORD="" F  S ORD=$O(^IBE(358.1,"D",ORD)) Q:ORD=""  S BLK=0 F  S BLK=$O(^IBE(358.1,"D",ORD,BLK)) Q:'BLK  D
  1.  . S NAME=$P($G(^IBE(358.1,+BLK,0)),"^")
  1.  . ;
  1.  . ;- Not a tool kit block
  1.  . Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1
  1.  . ;
  1.  . ;- Delete block if it already exists
  1.  . S IBTKBLK=1
  1.  . S IBDNM="" F  S IBDNM=$O(^IBE(357.1,"B",IBDNM)) Q:IBDNM=""  S IBDBLK=0 F  S IBDBLK=+$O(^IBE(357.1,"B",IBDNM,IBDBLK)) Q:'IBDBLK  D
  1.  .. I $P($G(^IBE(357.1,IBDBLK,0)),"^")=NAME D DLTBLK^IBDFU3(IBDBLK,"",357.1)
  1.  . S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)
  1.  . S CNTB=CNTB+1
  1.  . D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)
  1.  . ;
  1.  . ;- Add block name to array (used in summary at end)
  1.  . S SUMMARY(NUM)=NAME
  1.  . S NUM=NUM+1
  1.  . ;
  1.  . ;- Display msg to user
  1.  . D BMES^XPDUTL(">>> Moving encounter form block "_$G(NAME)_" from")
  1.  . D MES^XPDUTL("    AICS Import/Export files to AICS Tool Kit.")
  1.  ;
  1.  ;- Clear workspace
  1.  D DLTALL^IBDE2
  1.  D BMES^XPDUTL("... completed.")
  1.  ;
  1. SUMM ;- EF block summary displayed to user
  1.  D BMES^XPDUTL("Summary of Encounter Form Blocks Added to Tool Kit:")
  1.  D MES^XPDUTL("===================================================")
  1.  D MES^XPDUTL("")
  1.  F IBDX=0:0 S IBDX=$O(SUMMARY(IBDX)) Q:'IBDX  D
  1.  . D MES^XPDUTL($G(SUMMARY(IBDX)))
  1.  I '$D(SUMMARY) D
  1.  . D MES^XPDUTL(">>> ERROR: Missing data in IMP/EXP ENCOUNTER FORM BLOCK file (#358.1).")
  1.  . D MES^XPDUTL(">>> No Encounter Form Blocks were installed. Please contact National")
  1.  . D MES^XPDUTL(">>> Vista Support for assistance.")
  1.  Q
  1.  ;
  1.  ;
  1. TKERR ;- Display error msg if Tool Kit not found
  1.  D BMES^XPDUTL(">>> ERROR: No AICS Tool Kit found.  New encounter form blocks can not be")
  1.  D MES^XPDUTL(">>> installed.  Please contact National Vista Support for assistance.")
  1.  Q
  1.  ;
  1.  ;
  1. LIST ;- List of encounter form blocks
  1.  ;;BASIC DEMOGRAPHICS
  1.  ;;BASIC DEMOGRAPHICS (MST)
  1.  ;;PATIENT INFORMATION (V2.1)
  1.  ;;QUIT