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

IBDY337.m

Go to the documentation of this file. 
  1. IBDY337 ;ALB/DHH - PRE AND POST INSTALL FOR PATCH IBD*3*37 ; JUL 18, 2001
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**37**;APR 24, 1997
  1.  ;
  1. PRE ;- Create EF block list report and clear workspace before install
  1.  D CLWKSP
  1.  Q
  1.  ;
  1.  ;
  1. POST ;- Add toolkit blocks
  1.  D TKBLKS
  1.  D MISC
  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. TKBLKS ;- Add GAF 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,NODE,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 GAF 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 and is a toolkit block
  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.  .. S NODE=$G(^IBE(357.1,IBDBLK,0))
  1.  .. I $P((NODE),"^")=NAME,$P(NODE,"^",14) D 
  1.  ... 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. MISC ;- Misc. manual sets that will not transport via kid
  1.  ;
  1.  ;-- add GAF SCORE HANDPRINT to HAND PRINT FIELD (359.94)
  1.  ;
  1.  K DO
  1.  N DIC,X
  1.  S DIC="^IBE(359.94,",DIC(0)="Z"
  1.  S X="GAF SCORE HANDPRINT"
  1.  S DIC("DR")=".02///GAF Score:;.03///5;.04///10;.06///GAF SCORE HANDPRINT;.08///GAF HAND PRINT V3.0;.1///GAF SCORE"
  1.  D FILE^DICN
  1.  Q