IBDY338 ;ALB/DHH - POST INSTALL FOR PATCH IBD*3*38 ; OCT 1, 1999
;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
;
D ASK,ASK1
;
;-- Add CPT Modifier Tool Kit Blocks to Tool Kit
D AUTOINS
Q
;
ASK ;-- Set ASK CPT MODIFIERS to yes for DG SELECT CPT PROCEDURE CODES
; in the package interface file
;
D MES^XPDUTL(">>> Updating DG SELECT CPT PROCEDURE CODES Package Interface.")
N I,J,X
S I=0
F S I=$O(^IBE(357.6,"B",$E("DG SELECT CPT PROCEDURE CODES",1,30),I)) Q:'I D
.I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT CPT PROCEDURE CODES" S $P(^IBE(357.6,I,0),"^",21)=1
Q
;
ASK1 ;-- Set ASK CPT MODIFIERS to yes for DG SELECT VISIT TYPE PROCEDURES
; in the package interface file
;
D MES^XPDUTL(">>> Updating DG SELECT VISIT TYPE CPT PROCEDURES Package Interface.")
N I,J,X
S I=0
F S I=$O(^IBE(357.6,"B",$E("DG SELECT VISIT TYPE CPT PROCEDURES",1,30),I)) Q:'I D
.I $P($G(^IBE(357.6,I,0)),"^")="DG SELECT VISIT TYPE CPT PROCEDURES" S $P(^IBE(357.6,I,0),"^",21)=1
Q
;
AUTOINS ;-- Auto install CPT Modifier tool kit blocks into AICS Tool Kit
N FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB
D MES^XPDUTL(">>> Adding CPT Modifier Tool Kit Blocks to AICS Tool Kit.")
S (CNTB,CNTF)=0
;
;-- Add all tool kit blocks
S FORMNM="TOOL KIT"
I '$O(^IBE(357,"B",FORMNM,0)) Q
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)),"^")
.Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1 ;not toolkit
.I $O(^IBE(357.1,"B",NAME,0)) D MES^XPDUTL(" Block "_NAME_" already exists") Q
.D MES^XPDUTL(" Moving block '"_$P($G(^IBE(358.1,+BLK,0)),"^")_"' from Import/Export files to Tool Kit")
.N IBTKBLK S IBTKBLK=1
.S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13),CNTB=CNTB+1
.D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)
;
;-- Clear workspace
D DLTALL^IBDE2
Q
PREINIT ; Pre-Init for Patch 38
; clearing workspace - imp/exp
D MES^XPDUTL(">>> Clearing Import/Export Workspace Now...")
D DLTALL^IBDE2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDY338 2129 printed Sep 23, 2025@20:31:22 Page 2
IBDY338 ;ALB/DHH - POST INSTALL FOR PATCH IBD*3*38 ; OCT 1, 1999
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
+2 ;
+3 DO ASK
DO ASK1
+4 ;
+5 ;-- Add CPT Modifier Tool Kit Blocks to Tool Kit
+6 DO AUTOINS
+7 QUIT
+8 ;
ASK ;-- Set ASK CPT MODIFIERS to yes for DG SELECT CPT PROCEDURE CODES
+1 ; in the package interface file
+2 ;
+3 DO MES^XPDUTL(">>> Updating DG SELECT CPT PROCEDURE CODES Package Interface.")
+4 NEW I,J,X
+5 SET I=0
+6 FOR
SET I=$ORDER(^IBE(357.6,"B",$EXTRACT("DG SELECT CPT PROCEDURE CODES",1,30),I))
if 'I
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^IBE(357.6,I,0)),"^")="DG SELECT CPT PROCEDURE CODES"
SET $PIECE(^IBE(357.6,I,0),"^",21)=1
End DoDot:1
+8 QUIT
+9 ;
ASK1 ;-- Set ASK CPT MODIFIERS to yes for DG SELECT VISIT TYPE PROCEDURES
+1 ; in the package interface file
+2 ;
+3 DO MES^XPDUTL(">>> Updating DG SELECT VISIT TYPE CPT PROCEDURES Package Interface.")
+4 NEW I,J,X
+5 SET I=0
+6 FOR
SET I=$ORDER(^IBE(357.6,"B",$EXTRACT("DG SELECT VISIT TYPE CPT PROCEDURES",1,30),I))
if 'I
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^IBE(357.6,I,0)),"^")="DG SELECT VISIT TYPE CPT PROCEDURES"
SET $PIECE(^IBE(357.6,I,0),"^",21)=1
End DoDot:1
+8 QUIT
+9 ;
AUTOINS ;-- Auto install CPT Modifier tool kit blocks into AICS Tool Kit
+1 NEW FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB
+2 DO MES^XPDUTL(">>> Adding CPT Modifier Tool Kit Blocks to AICS Tool Kit.")
+3 SET (CNTB,CNTF)=0
+4 ;
+5 ;-- Add all tool kit blocks
+6 SET FORMNM="TOOL KIT"
+7 IF '$ORDER(^IBE(357,"B",FORMNM,0))
QUIT
+8 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
+9 SET NAME=$PIECE($GET(^IBE(358.1,+BLK,0)),"^")
+10 ;not toolkit
if $PIECE($GET(^IBE(358.1,BLK,0)),"^",14)'=1
QUIT
+11 IF $ORDER(^IBE(357.1,"B",NAME,0))
DO MES^XPDUTL(" Block "_NAME_" already exists")
QUIT
+12 DO MES^XPDUTL(" Moving block '"_$PIECE($GET(^IBE(358.1,+BLK,0)),"^")_"' from Import/Export files to Tool Kit")
+13 NEW IBTKBLK
SET IBTKBLK=1
+14 SET NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)
SET CNTB=CNTB+1
+15 if $GET(NEWBLOCK)
DO DLTBLK^IBDFU3(BLK,"",358.1)
End DoDot:1
+16 ;
+17 ;-- Clear workspace
+18 DO DLTALL^IBDE2
+19 QUIT
PREINIT ; Pre-Init for Patch 38
+1 ; clearing workspace - imp/exp
+2 DO MES^XPDUTL(">>> Clearing Import/Export Workspace Now...")
+3 DO DLTALL^IBDE2
+4 QUIT
