IBDY337 ;ALB/DHH - PRE AND POST INSTALL FOR PATCH IBD*3*37 ; JUL 18, 2001
;;3.0;AUTOMATED INFO COLLECTION SYS;**37**;APR 24, 1997
;
PRE ;- Create EF block list report and clear workspace before install
D CLWKSP
Q
;
;
POST ;- Add toolkit blocks
D TKBLKS
D MISC
Q
;
;
CLWKSP ;- Clear the AICS Import/Export Workspace (files in #358) before
;- loading new toolkit blocks
;
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Clearing AICS Import/Export workspace...")
D DLTALL^IBDE2
D MES^XPDUTL(">>> ...completed.")
Q
;
;
TKBLKS ;- Add GAF tool kit blocks to AICS Tool Kit
;
N A,ARY,BLK,CNT,CNT1,CNTB,CNTF,EXCLUDE,FORM,FORMNM,NAME,IBDNM,IBDBLK,IBDX,IBTKBLK,NEWBLOCK,NEWFORM,NODE,NUM,ORD,SUMMARY,X,Y
;
;- Add all tool kit blocks
S FORMNM="TOOL KIT"
S (CNTB,CNTF)=0,NUM=1
D BMES^XPDUTL(">>> Adding GAF Tool Kit blocks to the AICS Tool Kit...")
;
;- Display error msg and exit if Tool Kit not found
I '$O(^IBE(357,"B",FORMNM,0)) D TKERR Q
;
;- Get blocks from Imp/Exp EF Block file
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
. S NAME=$P($G(^IBE(358.1,+BLK,0)),"^")
. ;
. ;- Not a tool kit block
. Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1
. ;
. ;- Delete block if it already exists and is a toolkit block
. S IBTKBLK=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
.. S NODE=$G(^IBE(357.1,IBDBLK,0))
.. I $P((NODE),"^")=NAME,$P(NODE,"^",14) D
... D DLTBLK^IBDFU3(IBDBLK,"",357.1)
. S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)
. S CNTB=CNTB+1
. D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)
. ;
. ;- Add block name to array (used in summary at end)
. S SUMMARY(NUM)=NAME
. S NUM=NUM+1
. ;
. ;- Display msg to user
. D BMES^XPDUTL(">>> Moving encounter form block "_$G(NAME)_" from")
. D MES^XPDUTL(" AICS Import/Export files to AICS Tool Kit.")
;
;- Clear workspace
D DLTALL^IBDE2
D BMES^XPDUTL("... completed.")
;
SUMM ;- EF block summary displayed to user
D BMES^XPDUTL("Summary of Encounter Form Blocks Added to Tool Kit:")
D MES^XPDUTL("===================================================")
D MES^XPDUTL("")
F IBDX=0:0 S IBDX=$O(SUMMARY(IBDX)) Q:'IBDX D
. D MES^XPDUTL($G(SUMMARY(IBDX)))
I '$D(SUMMARY) D
. D MES^XPDUTL(">>> ERROR: Missing data in IMP/EXP ENCOUNTER FORM BLOCK file (#358.1).")
. D MES^XPDUTL(">>> No Encounter Form Blocks were installed. Please contact National")
. D MES^XPDUTL(">>> Vista Support for assistance.")
Q
;
;
TKERR ;- Display error msg if Tool Kit not found
D BMES^XPDUTL(">>> ERROR: No AICS Tool Kit found. New encounter form blocks can not be")
D MES^XPDUTL(">>> installed. Please contact National Vista Support for assistance.")
Q
;
;
MISC ;- Misc. manual sets that will not transport via kid
;
;-- add GAF SCORE HANDPRINT to HAND PRINT FIELD (359.94)
;
K DO
N DIC,X
S DIC="^IBE(359.94,",DIC(0)="Z"
S X="GAF SCORE HANDPRINT"
S DIC("DR")=".02///GAF Score:;.03///5;.04///10;.06///GAF SCORE HANDPRINT;.08///GAF HAND PRINT V3.0;.1///GAF SCORE"
D FILE^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDY337 3242 printed Mar 13, 2024@23:19:32 Page 2
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
+2 ;
PRE ;- Create EF block list report and clear workspace before install
+1 DO CLWKSP
+2 QUIT
+3 ;
+4 ;
POST ;- Add toolkit blocks
+1 DO TKBLKS
+2 DO MISC
+3 QUIT
+4 ;
+5 ;
CLWKSP ;- Clear the AICS Import/Export Workspace (files in #358) before
+1 ;- loading new toolkit blocks
+2 ;
+3 DO MES^XPDUTL("")
+4 DO BMES^XPDUTL(">>> Clearing AICS Import/Export workspace...")
+5 DO DLTALL^IBDE2
+6 DO MES^XPDUTL(">>> ...completed.")
+7 QUIT
+8 ;
+9 ;
TKBLKS ;- Add GAF tool kit blocks to AICS Tool Kit
+1 ;
+2 NEW A,ARY,BLK,CNT,CNT1,CNTB,CNTF,EXCLUDE,FORM,FORMNM,NAME,IBDNM,IBDBLK,IBDX,IBTKBLK,NEWBLOCK,NEWFORM,NODE,NUM,ORD,SUMMARY,X,Y
+3 ;
+4 ;- Add all tool kit blocks
+5 SET FORMNM="TOOL KIT"
+6 SET (CNTB,CNTF)=0
SET NUM=1
+7 DO BMES^XPDUTL(">>> Adding GAF Tool Kit blocks to the AICS Tool Kit...")
+8 ;
+9 ;- Display error msg and exit if Tool Kit not found
+10 IF '$ORDER(^IBE(357,"B",FORMNM,0))
DO TKERR
QUIT
+11 ;
+12 ;- Get blocks from Imp/Exp EF Block file
+13 SET ORD=""
FOR
SET ORD=$ORDER(^IBE(358.1,"D",ORD))
if ORD=""
QUIT
SET BLK=0
FOR
SET BLK=$ORDER(^IBE(358.1,"D",ORD,BLK))
if 'BLK
QUIT
Begin DoDot:1
+14 SET NAME=$PIECE($GET(^IBE(358.1,+BLK,0)),"^")
+15 ;
+16 ;- Not a tool kit block
+17 if $PIECE($GET(^IBE(358.1,BLK,0)),"^",14)'=1
QUIT
+18 ;
+19 ;- Delete block if it already exists and is a toolkit block
+20 SET IBTKBLK=1
+21 SET IBDNM=""
FOR
SET IBDNM=$ORDER(^IBE(357.1,"B",IBDNM))
if IBDNM=""
QUIT
SET IBDBLK=0
FOR
SET IBDBLK=+$ORDER(^IBE(357.1,"B",IBDNM,IBDBLK))
if 'IBDBLK
QUIT
Begin DoDot:2
+22 SET NODE=$GET(^IBE(357.1,IBDBLK,0))
+23 IF $PIECE((NODE),"^")=NAME
IF $PIECE(NODE,"^",14)
Begin DoDot:3
+24 DO DLTBLK^IBDFU3(IBDBLK,"",357.1)
End DoDot:3
End DoDot:2
+25 SET NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)
+26 SET CNTB=CNTB+1
+27 if $GET(NEWBLOCK)
DO DLTBLK^IBDFU3(BLK,"",358.1)
+28 ;
+29 ;- Add block name to array (used in summary at end)
+30 SET SUMMARY(NUM)=NAME
+31 SET NUM=NUM+1
+32 ;
+33 ;- Display msg to user
+34 DO BMES^XPDUTL(">>> Moving encounter form block "_$GET(NAME)_" from")
+35 DO MES^XPDUTL(" AICS Import/Export files to AICS Tool Kit.")
End DoDot:1
+36 ;
+37 ;- Clear workspace
+38 DO DLTALL^IBDE2
+39 DO BMES^XPDUTL("... completed.")
+40 ;
SUMM ;- EF block summary displayed to user
+1 DO BMES^XPDUTL("Summary of Encounter Form Blocks Added to Tool Kit:")
+2 DO MES^XPDUTL("===================================================")
+3 DO MES^XPDUTL("")
+4 FOR IBDX=0:0
SET IBDX=$ORDER(SUMMARY(IBDX))
if 'IBDX
QUIT
Begin DoDot:1
+5 DO MES^XPDUTL($GET(SUMMARY(IBDX)))
End DoDot:1
+6 IF '$DATA(SUMMARY)
Begin DoDot:1
+7 DO MES^XPDUTL(">>> ERROR: Missing data in IMP/EXP ENCOUNTER FORM BLOCK file (#358.1).")
+8 DO MES^XPDUTL(">>> No Encounter Form Blocks were installed. Please contact National")
+9 DO MES^XPDUTL(">>> Vista Support for assistance.")
End DoDot:1
+10 QUIT
+11 ;
+12 ;
TKERR ;- Display error msg if Tool Kit not found
+1 DO BMES^XPDUTL(">>> ERROR: No AICS Tool Kit found. New encounter form blocks can not be")
+2 DO MES^XPDUTL(">>> installed. Please contact National Vista Support for assistance.")
+3 QUIT
+4 ;
+5 ;
MISC ;- Misc. manual sets that will not transport via kid
+1 ;
+2 ;-- add GAF SCORE HANDPRINT to HAND PRINT FIELD (359.94)
+3 ;
+4 KILL DO
+5 NEW DIC,X
+6 SET DIC="^IBE(359.94,"
SET DIC(0)="Z"
+7 SET X="GAF SCORE HANDPRINT"
+8 SET DIC("DR")=".02///GAF Score:;.03///5;.04///10;.06///GAF SCORE HANDPRINT;.08///GAF HAND PRINT V3.0;.1///GAF SCORE"
+9 DO FILE^DICN
+10 QUIT