source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDY338.m@ 996

Last change on this file since 996 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.0 KB
Line 
1IBDY338 ;ALB/DHH - POST INSTALL FOR PATCH IBD*3*38 ; OCT 1, 1999
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
3 ;
4 D ASK,ASK1
5 ;
6 ;-- Add CPT Modifier Tool Kit Blocks to Tool Kit
7 D AUTOINS
8 Q
9 ;
10ASK ;-- Set ASK CPT MODIFIERS to yes for DG SELECT CPT PROCEDURE CODES
11 ; in the package interface file
12 ;
13 D MES^XPDUTL(">>> Updating DG SELECT CPT PROCEDURE CODES Package Interface.")
14 N I,J,X
15 S I=0
16 F S I=$O(^IBE(357.6,"B",$E("DG SELECT CPT PROCEDURE CODES",1,30),I)) Q:'I D
17 .I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT CPT PROCEDURE CODES" S $P(^IBE(357.6,I,0),"^",21)=1
18 Q
19 ;
20ASK1 ;-- Set ASK CPT MODIFIERS to yes for DG SELECT VISIT TYPE PROCEDURES
21 ; in the package interface file
22 ;
23 D MES^XPDUTL(">>> Updating DG SELECT VISIT TYPE CPT PROCEDURES Package Interface.")
24 N I,J,X
25 S I=0
26 F S I=$O(^IBE(357.6,"B",$E("DG SELECT VISIT TYPE CPT PROCEDURES",1,30),I)) Q:'I D
27 .I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT VISIT TYPE CPT PROCEDURES" S $P(^IBE(357.6,I,0),"^",21)=1
28 Q
29 ;
30AUTOINS ;-- Auto install CPT Modifier tool kit blocks into AICS Tool Kit
31 N FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB
32 D MES^XPDUTL(">>> Adding CPT Modifier Tool Kit Blocks to AICS Tool Kit.")
33 S (CNTB,CNTF)=0
34 ;
35 ;-- Add all tool kit blocks
36 S FORMNM="TOOL KIT"
37 I '$O(^IBE(357,"B",FORMNM,0)) Q
38 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
39 .S NAME=$P($G(^IBE(358.1,+BLK,0)),"^")
40 .Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1 ;not toolkit
41 .I $O(^IBE(357.1,"B",NAME,0)) D MES^XPDUTL(" Block "_NAME_" already exists") Q
42 .D MES^XPDUTL(" Moving block '"_$P($G(^IBE(358.1,+BLK,0)),"^")_"' from Import/Export files to Tool Kit")
43 .N IBTKBLK S IBTKBLK=1
44 .S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13),CNTB=CNTB+1
45 .D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)
46 ;
47 ;-- Clear workspace
48 D DLTALL^IBDE2
49 Q
50PREINIT ; Pre-Init for Patch 38
51 ; clearing workspace - imp/exp
52 D MES^XPDUTL(">>> Clearing Import/Export Workspace Now...")
53 D DLTALL^IBDE2
54 Q
Note: See TracBrowser for help on using the repository browser.